├── src ├── .gitignore ├── Makevars ├── Makevars.win ├── RcppExports.cpp └── mbbefdRcppCode.cpp ├── .gitignore ├── data ├── beaonre.rda ├── asiacomrisk.rda ├── lossalaefull.rda └── itagradescore.rda ├── tests ├── testthat.R ├── test-fit-oiunif.R ├── testthat │ └── testsDistr.R ├── test-fit-oibeta.R ├── test-fit-oigbeta.R ├── test-fit-oistpareto.R ├── test-mbbefd-1stparam-moment.R ├── test-mbbefd-2ndparam-moment.R ├── test-shftrncPareto.R ├── test-eecf.R ├── test-1inf-unif.R ├── test-fit-MBBEFDgb.R ├── test-beta.R ├── test-1inf-beta.R ├── test-1inf-shftrncPareto.R ├── test-fit-mbbefdab.R ├── test-beaonre.R ├── test-asiacom.R ├── test-mbbefd-2ndparam-def-prog.R ├── test-1inf-GB1.R ├── check-formula-variance.R ├── test-smokedfish.R ├── test-lossalae.R ├── test-mbbefd-2ndparam-grLL.R ├── test-1inf-mean.R ├── test-mbbefd-1stparam-def-prog.R ├── test-rng-mbbefd.R ├── test-GB1.R ├── test-mbbefd-1stparam.R ├── test-mbbefd-2ndparam.R ├── check-formula-integral.R └── test-fit-gbeta.R ├── demo ├── 00Index └── initializers.R ├── AUTHORS ├── R ├── data-swissrecurves.R ├── util-internal-test-mean.R ├── distr-theo-ecf.R ├── util-gendilogintegral.R ├── zzz.R ├── util-CInftransform.R ├── distr-1infl-unif.R ├── distr-1infl-shftrncPareto.R ├── distr-mbbefdR-fromCppfile-old.R ├── distr-mbbefdCpp.R ├── distr-1infl-genbeta.R ├── distr-1infl-beta.R ├── data-documentData-old.R ├── RcppExports.R ├── distr-shftrncPareto.R ├── distr-1infl-distrib.R ├── util-constr-mbbefd.R ├── fitDR-output.R ├── util-loglikfunc.R ├── graph-eccomp.R ├── fitDR-bootstrap.R ├── fitDR-prefit.R ├── distr-GB1.R ├── util-empiricalfunctions.R ├── distr-mbbefdR-1stparam.R └── distr-mbbefdR-2ndparam.R ├── .travis.yml ├── .Rbuildignore ├── mbbefd.Rproj ├── man ├── g2a.Rd ├── etl.Rd ├── swissRe.Rd ├── beaonre.Rd ├── itagradscore.Rd ├── exposureCurve.Rd ├── distr-sfttrncPareto.Rd ├── 1infl-unif.Rd ├── mbbefd-package.Rd ├── 1infl-stpareto.Rd ├── 1infl-beta.Rd ├── 1infl-genbeta.Rd ├── 1infl-Distribution.Rd ├── lossalae.Rd ├── eecf.Rd ├── distr-genbeta.Rd ├── graph-eccomp.Rd ├── mbbefdDistribution.Rd ├── asiacomrisk.Rd ├── bootDR.Rd └── fitDR.Rd ├── inst ├── CITATION └── NEWS.md ├── .travis_old.yml ├── DESCRIPTION ├── README.md ├── vignettes ├── test-beta.Rmd └── mbbefd.bib └── NAMESPACE /src/.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | *.so 3 | *.dll 4 | -------------------------------------------------------------------------------- /src/Makevars: -------------------------------------------------------------------------------- 1 | PKG_CPPFLAGS = -DRCPP_USE_UNWIND_PROTECT 2 | -------------------------------------------------------------------------------- /src/Makevars.win: -------------------------------------------------------------------------------- 1 | PKG_CPPFLAGS = -DRCPP_USE_UNWIND_PROTECT 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | /vignettes/*.log -------------------------------------------------------------------------------- /data/beaonre.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/spedygiorgio/mbbefd/HEAD/data/beaonre.rda -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(mbbefd) 3 | 4 | test_check("mbbefd") 5 | -------------------------------------------------------------------------------- /data/asiacomrisk.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/spedygiorgio/mbbefd/HEAD/data/asiacomrisk.rda -------------------------------------------------------------------------------- /data/lossalaefull.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/spedygiorgio/mbbefd/HEAD/data/lossalaefull.rda -------------------------------------------------------------------------------- /data/itagradescore.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/spedygiorgio/mbbefd/HEAD/data/itagradescore.rda -------------------------------------------------------------------------------- /demo/00Index: -------------------------------------------------------------------------------- 1 | initializers Functions to get the initialization parameters (see package vignettes) 2 | -------------------------------------------------------------------------------- /AUTHORS: -------------------------------------------------------------------------------- 1 | Christophe DUTANG 2 | Univ. Grenoble Alpes, CNRS, Grenoble INP, LJK, Grenoble, France 3 | Giorgio Alfredo SPEDICATO 4 | Markus GESMANN 5 | -------------------------------------------------------------------------------- /R/data-swissrecurves.R: -------------------------------------------------------------------------------- 1 | 2 | ####Swiss Re curves#### 3 | 4 | swissRe<-function(c) 5 | { 6 | out<-numeric(2) 7 | b <- exp(3.1 - 0.15*c*(1+c)) 8 | g <-exp(c*(0.78 + 0.12*c)) 9 | out<-c(b,g) 10 | names(out)<-c("b","g") 11 | return(out) 12 | } 13 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: r 2 | r: 3 | - devel 4 | sudo: false 5 | cache: packages 6 | warnings_are_errors: true 7 | cran: http://cran.rstudio.com 8 | addons: 9 | apt: 10 | update: true 11 | packages: 12 | - libgs-dev 13 | - qpdf 14 | - ghostscript -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | ^\.travis\.yml$ 4 | ^\.travis_old\.yml$ 5 | ^data-raw$ 6 | vignettes/figure/ 7 | vignettes/*\.tex 8 | vignettes/*\.md 9 | vignettes/test-beta.Rmd 10 | AUTHORS 11 | LICENCE 12 | tests/check-formula* 13 | tests/test-mbbefd-* 14 | -------------------------------------------------------------------------------- /R/util-internal-test-mean.R: -------------------------------------------------------------------------------- 1 | #internal test function of expectation for one-inflated distribution 2 | 3 | tmean1 <- function(doifun, ...) 4 | integrate(function(x) x*doifun(x, ...), 0, 1)$value + 1*doifun(x=1, ...) 5 | tmean2 <- function(poifun, ...) 6 | integrate(function(x) 1-poifun(x, ...), 0, 1)$value 7 | tmean3 <- function(ecoifun, eps=1e-9, ...) 8 | eps/ecoifun(eps, ...) 9 | 10 | -------------------------------------------------------------------------------- /R/distr-theo-ecf.R: -------------------------------------------------------------------------------- 1 | #new exposure curve function for some distributions 2 | #limited expected value is implemented in actuar 3 | 4 | ecunif <- function(x, min = 0, max =1) 5 | { 6 | levunif(x, min = min, max = max) / munif(1, min = min, max = max) 7 | } 8 | 9 | ecbeta <- function(x, shape1, shape2) 10 | { 11 | levbeta(x, shape1 = shape1, shape2 = shape2) / mbeta(1, shape1 = shape1, shape2 = shape2) 12 | } 13 | -------------------------------------------------------------------------------- /mbbefd.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | BuildType: Package 16 | PackageUseDevtools: Yes 17 | PackageInstallArgs: --no-multiarch --with-keep.source 18 | PackageBuildArgs: --compact-vignettes=both 19 | PackageCheckArgs: --as-cran 20 | -------------------------------------------------------------------------------- /man/g2a.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2 (4.1.0): do not edit by hand 2 | % Please edit documentation in R/RcppExports.R 3 | \name{g2a} 4 | \alias{g2a} 5 | \title{Get a parameter known g and b} 6 | \usage{ 7 | g2a(g, b) 8 | } 9 | \arguments{ 10 | \item{g}{the g parameter} 11 | 12 | \item{b}{the b parameter} 13 | } 14 | \value{ 15 | a real value 16 | } 17 | \description{ 18 | \code{g2a} returns the a parameter known g and b 19 | } 20 | \seealso{ 21 | \code{\link{mbbefd-distr}}. 22 | } 23 | 24 | \examples{ 25 | g2a(10,2) 26 | } 27 | 28 | -------------------------------------------------------------------------------- /tests/test-fit-oiunif.R: -------------------------------------------------------------------------------- 1 | library(mbbefd) 2 | library(fitdistrplus) 3 | 4 | 5 | #oiunif 6 | n <- 1e3 7 | nboot <- 1000 8 | nboot <- 10 9 | x <- roiunif(n, 1/6) 10 | f1 <- fitDR(x, "oiunif", method="mle") 11 | summary(f1) 12 | summary(fitdist(x, "oiunif", method="mle", start=list(p1=1/2))) #check 13 | 14 | b1 <- bootDR(f1, niter=nboot, silent=FALSE) 15 | summary(b1) 16 | 17 | plot(b1) 18 | abline(v=1/6, col="red") 19 | 20 | hist(b1$estim[,1]) 21 | abline(v=1/6, col="red") 22 | 23 | 24 | f2 <- fitDR(x, "oiunif", method="tlmme") 25 | 26 | 27 | -------------------------------------------------------------------------------- /tests/testthat/testsDistr.R: -------------------------------------------------------------------------------- 1 | #unit testing 2 | library(testthat) 3 | library(mbbefd) 4 | 5 | context("Check some values with Mahler") 6 | 7 | test_that("some values", { 8 | expect_equal(round(ecmbbefd(x=1/2,a = .2,b = .04),2), 0.68) 9 | expect_equal(round(dmbbefd(x = .1, a=.2, b=.04),2), .65) 10 | expect_equal(round(1-pmbbefd(q= .6, a=.2, b=.04),4),.5043) 11 | }) 12 | 13 | 14 | test_that("mbbefdExposure", { 15 | expect_equal(ecmbbefd(0.5, a=1, b=1), 0.5) 16 | expect_equal(ecmbbefd(0.5, a=0, b=1), 0.5) 17 | expect_equal(ecmbbefd(0.5, a=0, b=0), NaN) 18 | 19 | }) 20 | 21 | -------------------------------------------------------------------------------- /R/util-gendilogintegral.R: -------------------------------------------------------------------------------- 1 | # 2 | # #integral(from=0, to=1, function(x) a+b^x) 3 | # gendilog <- function(a, b, checkparam=TRUE) 4 | # { 5 | # if(!(a +1 >0 && b > 0 && a*(1-b) >= 0) && checkparam) 6 | # return(NaN) 7 | # 8 | # if(a == 0) 9 | # return(log(b)/2) 10 | # else if(b == 1) 11 | # return(log(a+1)) 12 | # else if(a > 0) 13 | # { 14 | # res <- (dilog(-1/a) - dilog(-b/a))/log(b)+log(a) 15 | # }else 16 | # { 17 | # res <- (dilog(1+b/a) - dilog(1+1/a))/log(b) 18 | # res <- res + log(a+b) - log(-a)*log((a+b)/(a+1))/log(b) 19 | # } 20 | # res 21 | # } 22 | -------------------------------------------------------------------------------- /tests/test-fit-oibeta.R: -------------------------------------------------------------------------------- 1 | library(mbbefd) 2 | library(fitdistrplus) 3 | 4 | 5 | #oibeta 6 | n <- 1e3 7 | nboot <- 1000 8 | nboot <- 10 9 | set.seed(12345) 10 | x <- roibeta(n, 3, 2, 1/6) 11 | 12 | f1 <- fitDR(x, "oibeta", method="mle") 13 | summary(f1) 14 | 15 | b1 <- bootDR(f1, niter=nboot) 16 | summary(b1) 17 | 18 | plot(b1, enhance=TRUE, trueval=c(3, 2, 1/6)) 19 | 20 | hist(b1$estim[,1]) 21 | hist(b1$estim[,2]) 22 | hist(b1$estim[,3]) 23 | 24 | 25 | f2 <- fitDR(x, "oigbeta", method="tlmme") 26 | summary(f2) 27 | 28 | gofstat(list(f1, f2)) 29 | cdfcomp(list(f1, f2), do.points=FALSE) 30 | ppcomp(list(f1, f2)) 31 | -------------------------------------------------------------------------------- /tests/test-fit-oigbeta.R: -------------------------------------------------------------------------------- 1 | library(mbbefd) 2 | library(fitdistrplus) 3 | 4 | 5 | #oigbeta 6 | n <- 1e3 7 | nboot <- 1000 8 | nboot <- 10 9 | set.seed(12345) 10 | x <- roigbeta(n, 3, 2, 5/2, 1/6) 11 | 12 | 13 | f1 <- fitDR(x, "oigbeta", method="mle", control=list(trace=1, REPORT=1, maxit=500)) # 14 | summary(f1) 15 | 16 | b1 <- bootDR(f1, niter=nboot, silent=TRUE) 17 | summary(b1) 18 | 19 | plot(b1, enhance=TRUE, trueval=c(3, 2, 5/2, 1/6)) 20 | 21 | f2 <- fitDR(x, "oigbeta", method="tlmme") 22 | summary(f2) 23 | 24 | gofstat(list(f1, f2)) 25 | cdfcomp(list(f1, f2), do.points=FALSE, ylogscale = TRUE) 26 | ppcomp(list(f1, f2)) 27 | 28 | -------------------------------------------------------------------------------- /inst/CITATION: -------------------------------------------------------------------------------- 1 | citHeader("To cite mbbefd in publications use:") 2 | 3 | year <- 2025 4 | note <- sprintf("R package version %s", meta$Version) 5 | 6 | bibentry(bibtype = "Manual", 7 | title = "mbbefd: {Maxwell} {Boltzmann} {Bose} {Einstein} {Fermi} {Dirac} Distribution and Destruction Rate Modelling", 8 | author = c(person("Christophe", "Dutang"), person("Giorgio", "Spedicato")), 9 | year = year, 10 | note = note, 11 | url = "https://CRAN.R-project.org/package=mbbefd") 12 | 13 | citFooter("Please cite both the package and R when using them for data analysis.", 14 | "See also", sQuote("citation()"), 15 | "for citing R.") 16 | -------------------------------------------------------------------------------- /tests/test-fit-oistpareto.R: -------------------------------------------------------------------------------- 1 | library(mbbefd) 2 | library(fitdistrplus) 3 | 4 | 5 | #oistpareto 6 | n <- 1e3 7 | nboot <- 1000 8 | nboot <- 10 9 | set.seed(12345) 10 | x <- roistpareto(n, 2, 1/6) 11 | 12 | f1 <- fitDR(x, "oistpareto", method="mle") 13 | summary(f1) 14 | summary(fitdist(x, "oistpareto", method="mle", start=list(a=1/mean(x), p1=etl(x))))#check 15 | 16 | b1 <- bootDR(f1, niter=nboot) 17 | summary(b1) 18 | 19 | plot(b1, enhance=TRUE, trueval=c(2, 1/6)) 20 | 21 | hist(b1$estim[,1]) 22 | hist(b1$estim[,2]) 23 | 24 | f2 <- fitDR(x, "oistpareto", method="tlmme") 25 | summary(f2) 26 | 27 | gofstat(list(f1, f2)) 28 | cdfcomp(list(f1, f2), do.points=FALSE) 29 | ppcomp(list(f1, f2)) 30 | -------------------------------------------------------------------------------- /tests/test-mbbefd-1stparam-moment.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | library(mbbefd) 4 | 5 | f <- function(x, k, a, b) 6 | pmbbefd(x^(1/k), a, b, lower.tail = FALSE) 7 | 8 | integrate(f, k=1, a=2, b=1/2, lower=0, upper = 1) 9 | mmbbefd(1, 2, 1/2) 10 | 11 | integrate(function(x, b) b^(x), b=1/2, lower=0, upper = 1) 12 | mmbbefd(1, Inf, 1/2) 13 | 14 | integrate(f, k=2, a=2, b=1/2, lower=0, upper = 1) 15 | mmbbefd(2, 2, 1/2) 16 | 17 | integrate(function(x, b) b^(sqrt(x)), b=1/2, lower=0, upper = 1) 18 | mmbbefd(2, Inf, 1/2) 19 | 20 | integrate(f, k=pi, a=2, b=1/2, lower=0, upper = 1) 21 | mmbbefd(pi, 2, 1/2) 22 | 23 | integrate(function(x, b, k) b^(x^(1/pi)), k=pi, b=1/2, lower=0, upper = 1) 24 | mmbbefd(pi, Inf, 1/2) 25 | 26 | -------------------------------------------------------------------------------- /tests/test-mbbefd-2ndparam-moment.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | library(mbbefd) 4 | 5 | f <- function(x, k, g, b) 6 | pMBBEFD(x^(1/k), g, b, lower.tail = FALSE) 7 | 8 | integrate(f, k=1, g=2, b=1/3, lower=0, upper = 1) 9 | mMBBEFD(1, 2, 1/3) 10 | 11 | integrate(f, k=2, g=2, b=1/3, lower=0, upper = 1) 12 | mMBBEFD(2, 2, 1/3) 13 | 14 | integrate(f, k=pi, g=2, b=1/3, lower=0, upper = 1) 15 | mMBBEFD(pi, 2, 1/3) 16 | 17 | 18 | 19 | integrate(function(x, b) b^(x), b=1/2, lower=0, upper = 1) 20 | mMBBEFD(1, 2, 1/2) 21 | 22 | integrate(function(x, b) b^(sqrt(x)), b=1/2, lower=0, upper = 1) 23 | mMBBEFD(2, 2, 1/2) 24 | 25 | integrate(function(x, b, k) b^(x^(1/pi)), k=pi, b=1/2, lower=0, upper = 1) 26 | mMBBEFD(pi, 2, 1/2) 27 | 28 | -------------------------------------------------------------------------------- /tests/test-shftrncPareto.R: -------------------------------------------------------------------------------- 1 | library(mbbefd) 2 | 3 | #test of shifted truncated pareto distribution 4 | n <- 1e4 5 | 6 | x <- rstpareto(n, 2) 7 | y <- rstpareto(n, 1/2) 8 | 9 | #test CDF 10 | z <- 0:10/10 11 | cbind(ecdf(x)(z), pstpareto(z, 2)) 12 | 13 | cbind(ecdf(y)(z), pstpareto(z, 1/2)) 14 | 15 | #mean 16 | c(mean(x), mstpareto(1, 2)) 17 | c(mean(y), mstpareto(1, 1/2)) 18 | 19 | #test EC 20 | cbind(eecf(x)(z), ecstpareto(z, 2)) 21 | 22 | cbind(eecf(y)(z), ecstpareto(z, 1/2)) 23 | 24 | 25 | plot(eecf(x)) 26 | v <- seq(0, 1, length=101) 27 | lines(v, ecstpareto(v, 2), lty=3, col="red") 28 | 29 | 30 | plot(eecf(y)) 31 | v <- seq(0, 1, length=101) 32 | lines(v, ecstpareto(v, 1/2), lty=3, col="red") 33 | 34 | -------------------------------------------------------------------------------- /R/zzz.R: -------------------------------------------------------------------------------- 1 | # TODO: Add comment 2 | # 3 | # Author: Giorgio 4 | ############################################################################### 5 | 6 | #adding a startup message 7 | #for future version, should test : if(verbose <- getOption("verbose")) 8 | 9 | .onAttach <- function(libname, pkgname) { 10 | desc <- packageDescription(pkgname, libname) 11 | packageStartupMessage('Package: ', desc$Package, '\n', 12 | 'Version: ', desc$Version, '\n', 13 | 'Date: ', desc$Date, '\n', 14 | 'BugReport: ', desc$BugReports, '\n\n') 15 | } 16 | 17 | 18 | 19 | 20 | # for unloading dynamic libraries 21 | 22 | .onUnload <- function (libpath) { 23 | library.dynam.unload("mbbefd", libpath) 24 | } -------------------------------------------------------------------------------- /R/util-CInftransform.R: -------------------------------------------------------------------------------- 1 | 2 | # Infinitely differentiable transformations of R into a bounded or half-bounded interval 3 | 4 | #Transformation from (-Inf, +Inf) to (-1, 0) 5 | Trans.m10 <- function(x) 6 | -1/(1+exp(-x)) 7 | #Inverse 8 | InvT.m10 <- function(x) 9 | log(-x/(1+x)) 10 | 11 | #Transformation from (-Inf, +Inf) to (0, 1) 12 | Trans.01 <- function(x) 13 | 1/(1+exp(-x)) 14 | #Inverse 15 | InvT.01 <- function(x) 16 | log(x/(1-x)) 17 | 18 | #Transformation from (-Inf, +Inf) to (0, +Inf) 19 | Trans.0Inf <- function(x) 20 | exp(x) 21 | #Inverse 22 | InvT.0Inf <- function(x) 23 | log(x) 24 | 25 | #Transformation from (-Inf, +Inf) to (1, +Inf) 26 | Trans.1Inf <- function(x) 27 | 1+exp(x) 28 | #Inverse 29 | InvT.1Inf <- function(x) 30 | log(x-1) 31 | 32 | -------------------------------------------------------------------------------- /tests/test-eecf.R: -------------------------------------------------------------------------------- 1 | library(mbbefd) 2 | 3 | #test of shifted truncated pareto distribution 4 | n <- 1e1 5 | 6 | x <- rstpareto(n, 2)+0.01 7 | y <- rstpareto(n, 2) 8 | 9 | #test CDF 10 | z <- 0:4/4 11 | ecdf(x)(z) 12 | 13 | #test EC 14 | f <- function(d) 15 | mean(pmin(x, d))/mean(x) 16 | rval <- Vectorize(f, "d") 17 | 18 | cbind(eecf(x)(x), rval(x)) 19 | cbind(eecf(x)(z), rval(z)) 20 | 21 | class(eecf(x)) 22 | class(ecdf(x)) 23 | 24 | print(eecf(x)) 25 | print(ecdf(x)) 26 | 27 | cbind(eecf(x)(sort(x)), 28 | environment(eecf(x))$"Gx") 29 | 30 | print(summary(eecf(x))) 31 | print(summary(ecdf(x))) 32 | 33 | plot(eecf(x)) 34 | plot(ecdf(x)) 35 | 36 | 37 | plot(eecf(x)) 38 | plot(eecf(y), add=TRUE, col="red") 39 | lines(eecf(y[1:5]), col="green") 40 | 41 | ?plot.eecf 42 | ?summary.eecf 43 | -------------------------------------------------------------------------------- /demo/initializers.R: -------------------------------------------------------------------------------- 1 | #function that uses the fist itetation of method of moments method of moments to get the inits 2 | 3 | giveFunction2Minimize<-function(mu,g) { 4 | out = function(b) (mu - (log(g*b)*(1 - b))/( log(b)*(1 - g*b)) )^2 5 | return(out) 6 | } 7 | 8 | #this function returns the suqared 9 | 10 | giveFunction2Integrate<-function(b,g) { 11 | out = function(x) x^2*dmbbefd(x,b=b,g=g) 12 | return(out) 13 | } 14 | 15 | giveInits<-function(x) { 16 | m0<-mean(x) 17 | m2<-mean(x^2) 18 | 19 | #p<=1/g 20 | 21 | p0=m2 #m2 upper limit of p0 22 | g=1/p0 23 | 24 | #equate 1rst moment to get the mean 25 | myMin<-giveFunction2Minimize(mu=m0,g=g) 26 | b<-nlm(f=myMin,p=.1)$estimate 27 | 28 | #return a 29 | a=(g-1)*b/(1-g*b) 30 | out<-list(a=a, b=b) 31 | return(out) 32 | } 33 | -------------------------------------------------------------------------------- /.travis_old.yml: -------------------------------------------------------------------------------- 1 | language: r 2 | r: devel 3 | sudo: true 4 | cache: packages 5 | 6 | warnings_are_errors: true 7 | 8 | before_install: 9 | ## PPA for Rcpp and some other packages 10 | - sudo add-apt-repository -y ppa:edd/misc 11 | - curl -OL http://raw.github.com/craigcitro/r-travis/master/scripts/travis-tool.sh 12 | - chmod 755 ./travis-tool.sh 13 | - ./travis-tool.sh bootstrap 14 | - ./travis-tool.sh install_aptget libgsl0-dev gsl-bin 15 | 16 | install: 17 | - ./travis-tool.sh install_deps 18 | 19 | script: ./travis-tool.sh run_tests 20 | 21 | after_script: 22 | - ./travis-tool.sh dump_logs 23 | 24 | notifications: 25 | email: false 26 | 27 | env: 28 | global: 29 | - CRAN: http://cran.rstudio.com 30 | - R_BUILD_ARGS=" --compact-vignettes=gs+qpdf" 31 | - R_CHECK_ARGS="--as-cran" 32 | - BOOTSTRAP_LATEX="1" 33 | -------------------------------------------------------------------------------- /tests/test-1inf-unif.R: -------------------------------------------------------------------------------- 1 | library(mbbefd) 2 | 3 | #test of uniform distribution 4 | n <- 1e4 5 | 6 | x <- roiunif(n, p1=1/2) 7 | y <- roiunif(n, p1=1/3) 8 | 9 | #test CDF 10 | z <- 0:10/10 11 | cbind(ecdf(x)(z), poiunif(z, 1/2)) 12 | 13 | cbind(ecdf(y)(z), poiunif(z, 1/3)) 14 | 15 | #total loss 16 | c(etl(x), tloiunif(1/2)) 17 | c(etl(y), tloiunif(1/3)) 18 | 19 | #mean 20 | c(mean(x), moiunif(1, 1/2)) 21 | c(mean(y), moiunif(1, 1/3)) 22 | 23 | 24 | #test EC 25 | cbind(eecf(x)(z), ecoiunif(z, 1/2)) 26 | cbind(eecf(y)(z), ecoiunif(z, 1/3)) 27 | 28 | 29 | 30 | #plots 31 | n <- 1e2 32 | x <- roiunif(n, p1=1/2) 33 | y <- roiunif(n, p1=1/3) 34 | 35 | 36 | plot(eecf(x), do.points=FALSE) 37 | v <- seq(0, 1, length=101) 38 | lines(v, ecoiunif(v, 1/2), lty=3, col="red") 39 | 40 | 41 | plot(eecf(y), do.points=FALSE) 42 | v <- seq(0, 1, length=101) 43 | lines(v, ecoiunif(v, 1/3), lty=3, col="red") 44 | 45 | -------------------------------------------------------------------------------- /R/distr-1infl-unif.R: -------------------------------------------------------------------------------- 1 | #d, p, q, r function for one-inflated uniform distribution 2 | 3 | 4 | doiunif <- function(x, p1, log=FALSE) 5 | { 6 | doifun(x=x, dfun=dunif, p1=p1, log=log, min=0, max=1) 7 | } 8 | 9 | poiunif <- function(q, p1, lower.tail = TRUE, log.p = FALSE) 10 | { 11 | poifun(q=q, pfun=punif, p1=p1, lower.tail = lower.tail, log.p = log.p, min=0, max=1) 12 | } 13 | 14 | qoiunif <- function(p, p1, lower.tail = TRUE, log.p = FALSE) 15 | { 16 | qoifun(p=p, qfun=qunif, p1=p1, lower.tail = lower.tail, log.p = log.p, min=0, max=1) 17 | } 18 | 19 | roiunif <- function(n, p1) 20 | { 21 | roifun(n=n, rfun=runif, p1=p1, min=0, max=1) 22 | } 23 | 24 | 25 | ecoiunif <- function(x, p1) 26 | { 27 | ecoifun(x=x, ecfun=ecunif, mfun=munif, p1=p1, min=0, max=1) 28 | } 29 | 30 | moiunif <- function(order, p1) 31 | { 32 | moifun(order=order, mfun=munif, p1=p1, min=0, max=1) 33 | } 34 | 35 | tloiunif <- function(p1) 36 | { 37 | tloifun(p1=p1) 38 | } 39 | -------------------------------------------------------------------------------- /tests/test-fit-MBBEFDgb.R: -------------------------------------------------------------------------------- 1 | library(mbbefd) 2 | library(fitdistrplus) 3 | 4 | n <- 1e3 5 | nboot <- 1000 6 | nboot <- 10 7 | set.seed(123456) 8 | x <- rMBBEFD(n, 8, 1/4) 9 | 10 | system.time(f1 <- fitDR(x, "MBBEFD")) 11 | summary(f1) 12 | 13 | #should be similar 14 | f0 <- fitdist(x, "MBBEFD", start= list(g=4, b=1/2)) 15 | summary(f0) 16 | 17 | cdfcomp(f1, do.points=FALSE) 18 | qqcomp(f1) 19 | 20 | 21 | 22 | # llsurface(plot.min=c(1, 0), plot.max=c(11, 1/2), plot.arg=c("g", "b"), obs=x, distr="MBBEFD", nlevels=25) 23 | # points(f1$estimate["g"], f1$estimate["b"], pch="+", col="red") 24 | # points(8, 1/4, pch="x", col="black") 25 | 26 | 27 | b1 <- bootDR(f1, niter=nboot, silent=TRUE) 28 | plot(b1, enhance=TRUE, trueval=c(8, 1/4)) 29 | 30 | 31 | set.seed(123456) 32 | x <- rMBBEFD(n, 2, 1/4) 33 | 34 | system.time(f1 <- fitDR(x, "MBBEFD")) 35 | summary(f1) 36 | 37 | b1 <- bootDR(f1, niter=nboot, silent=TRUE) 38 | plot(b1, enhance=TRUE, trueval=c(2, 1/4)) 39 | 40 | -------------------------------------------------------------------------------- /R/distr-1infl-shftrncPareto.R: -------------------------------------------------------------------------------- 1 | # one-inflated shifted truncated Pareto distribution 2 | 3 | doistpareto <- function(x, a, p1, log=FALSE) 4 | { 5 | doifun(x=x, dfun=dstpareto, p1=p1, log=log, a=a) 6 | } 7 | 8 | poistpareto <- function(q, a, p1, lower.tail = TRUE, log.p = FALSE) 9 | { 10 | poifun(q=q, pfun=pstpareto, p1=p1, lower.tail = lower.tail, log.p = log.p, a=a) 11 | } 12 | 13 | qoistpareto <- function(p, a, p1, lower.tail = TRUE, log.p = FALSE) 14 | { 15 | qoifun(p=p, qfun=qstpareto, p1=p1, lower.tail = lower.tail, log.p = log.p, a=a) 16 | } 17 | 18 | roistpareto <- function(n, a, p1) 19 | { 20 | roifun(n=n, rfun=rstpareto, p1=p1, a=a) 21 | } 22 | 23 | ecoistpareto <- function(x, a, p1) 24 | { 25 | ecoifun(x=x, ecfun=ecstpareto, mfun=mstpareto, p1=p1, a=a) 26 | } 27 | 28 | moistpareto <- function(order, a, p1) 29 | { 30 | moifun(order=order, mfun=mstpareto, p1=p1, a=a) 31 | } 32 | 33 | tloistpareto <- function(a, p1) 34 | { 35 | tloifun(p1=p1, a=a) 36 | } 37 | 38 | -------------------------------------------------------------------------------- /man/etl.Rd: -------------------------------------------------------------------------------- 1 | \name{etl} 2 | \alias{etl} 3 | 4 | \title{ 5 | Empirical total loss 6 | } 7 | \description{ 8 | Compute the empirical total loss. 9 | 10 | } 11 | \usage{ 12 | etl(x, na.rm=FALSE) 13 | 14 | } 15 | 16 | \arguments{ 17 | \item{x}{numeric vector of the observations.} 18 | \item{na.rm}{a logical value indicating whether \code{NA} values should 19 | be stripped before the computation proceeds.} 20 | 21 | } 22 | \details{ 23 | Compute the empirical total loss defined as the proportion of full destruction rates, 24 | that is observations that equal 1. 25 | 26 | } 27 | \value{ 28 | A numeric value or a vector. 29 | } 30 | \author{ 31 | Dutang Christophe 32 | } 33 | 34 | \examples{ 35 | x <- c(1, 0.000495134903027804, 0.787229130724068, 0.71154311082138, 36 | 0.0669802789251427, 0.310872967333683, 1, 1, 1, 1, 0.162030982251957, 37 | 1, 1, 0.322530106394859, 1, 1, 1, 0.60805410798081, 0.660941675188664, 1) 38 | 39 | #empirical total loss (true value is 1/2) 40 | etl(x) 41 | } 42 | 43 | -------------------------------------------------------------------------------- /tests/test-beta.R: -------------------------------------------------------------------------------- 1 | library(mbbefd) 2 | 3 | #test of beta distribution 4 | n <- 1e4 5 | 6 | x <- roibeta(n, 2, 2, p1=0) 7 | y <- roibeta(n, 4/3, 2/3, p1=0) 8 | 9 | #test CDF 10 | z <- 0:10/10 11 | cbind(ecdf(x)(z), poibeta(z, 2, 2, 0)) 12 | 13 | cbind(ecdf(y)(z), poibeta(z, 4/3, 2/3, 0)) 14 | 15 | #total loss 16 | c(etl(x), tloibeta(2, 2, 0)) 17 | c(etl(y), tloibeta(4/3, 2/3, 0)) 18 | 19 | #mean 20 | c(mean(x), moibeta(1, 2, 2, 0)) 21 | c(mean(y), moibeta(1, 4/3, 2/3, 0)) 22 | 23 | 24 | #test EC 25 | cbind(eecf(x)(z), ecoibeta(z, 2, 2, 0)) 26 | cbind(eecf(y)(z), ecoibeta(z, 4/3, 2/3, 0)) 27 | 28 | 29 | 30 | #plots 31 | n <- 1e5 32 | n <- 1e2 33 | x <- roibeta(n, 2, 2, p1=0) 34 | y <- roibeta(n, 4/3, 2/3, p1=0) 35 | 36 | 37 | plot(eecf(x), do.points=FALSE) 38 | v <- seq(0, 1, length=101) 39 | lines(v, ecoibeta(v, 2, 2, 0), lty=3, col="red") 40 | 41 | 42 | plot(eecf(y), do.points=FALSE) 43 | v <- seq(0, 1, length=101) 44 | lines(v, ecoibeta(v, 4/3, 2/3, 0), lty=3, col="red") 45 | 46 | -------------------------------------------------------------------------------- /man/swissRe.Rd: -------------------------------------------------------------------------------- 1 | \name{swissRe} 2 | \alias{swissRe} 3 | 4 | \title{ 5 | Swiss Re exposure curve generation function 6 | } 7 | \description{ 8 | This function turns out the MBBEFD b and g parameters for the famous Swiss Re (SR) exposure curves. 9 | } 10 | \usage{ 11 | swissRe(c) 12 | } 13 | 14 | \arguments{ 15 | \item{c}{A numeric value} 16 | } 17 | \details{ 18 | The four Swiss Re Y1-Y4 are defined for c=1.5, 2, 3, 4. In addition c=5 coincides with a curve used by Lloyds for industrial risks exposure rating. 19 | } 20 | \value{ 21 | A named two dimensional vector 22 | } 23 | \references{ 24 | BERNEGGER, STEFAN (1997). 25 | \emph{The Swiss Re Exposure Curves And The MBBEFD Distribution Class}, 26 | ASTIN Bulletin, 27(1), pp99-111, \doi{https://doi.org/10.2143/AST.27.1.563208}. 27 | } 28 | \author{ 29 | Giorgio Spedicato 30 | } 31 | 32 | \seealso{ 33 | \code{\link{mbbefd-distr}}. 34 | } 35 | \examples{ 36 | pars <- swissRe(4) 37 | losses <- rMBBEFD(n=1000,b=pars[1],g=pars[2]) 38 | mean(losses) 39 | } 40 | -------------------------------------------------------------------------------- /tests/test-1inf-beta.R: -------------------------------------------------------------------------------- 1 | library(mbbefd) 2 | 3 | #test of 1-infl beta distribution 4 | n <- 1e4 5 | 6 | x <- roibeta(n, 2, 2, p1=1/2) 7 | y <- roibeta(n, 4/3, 2/3, p1=1/3) 8 | 9 | #test CDF 10 | z <- 0:10/10 11 | cbind(ecdf(x)(z), poibeta(z, 2, 2, 1/2)) 12 | 13 | cbind(ecdf(y)(z), poibeta(z, 4/3, 2/3, 1/3)) 14 | 15 | #total loss 16 | c(etl(x), tloibeta(2, 2, 1/2)) 17 | c(etl(y), tloibeta(4/3, 2/3, 1/3)) 18 | 19 | #mean 20 | c(mean(x), moibeta(1, 2, 2, 1/2)) 21 | c(mean(y), moibeta(1, 4/3, 2/3, 1/3)) 22 | 23 | 24 | #test EC 25 | cbind(eecf(x)(z), ecoibeta(z, 2, 2, 1/2)) 26 | cbind(eecf(y)(z), ecoibeta(z, 4/3, 2/3, 1/3)) 27 | 28 | 29 | 30 | #plots 31 | n <- 1e2 32 | x <- roibeta(n, 2, 2, p1=1/2) 33 | y <- roibeta(n, 4/3, 2/3, p1=1/3) 34 | 35 | 36 | plot(eecf(x), do.points=FALSE) 37 | v <- seq(0, 1, length=101) 38 | lines(v, ecoibeta(v, 2, 2, 1/2), lty=3, col="red") 39 | 40 | 41 | plot(eecf(y), do.points=FALSE) 42 | v <- seq(0, 1, length=101) 43 | lines(v, ecoibeta(v, 4/3, 2/3, 1/3), lty=3, col="red") 44 | 45 | -------------------------------------------------------------------------------- /R/distr-mbbefdR-fromCppfile-old.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | #exposure curve 4 | 5 | .G<-function(x, a, b, g) 6 | { 7 | stop("deprecated.") 8 | } 9 | 10 | #its derivative 11 | dG<-function(x,a,b,g) 12 | { 13 | stop("deprecated.") 14 | } 15 | 16 | #the survival function 17 | .Sx<-function(x,a,b,g) 18 | { 19 | stop("deprecated.") 20 | } 21 | 22 | #the function to compute the exposure function 23 | #could add the following line mbbefdExposure <- ecmbbefdR in mbbefdR-1stparam.R ? 24 | mbbefdExposure<-function(x, a, b, g) 25 | { 26 | stop("deprecated.") 27 | } 28 | 29 | 30 | 31 | #################################### 32 | #classical functions 33 | #distribution function 34 | pmbbefd2<-function(q,a,b,g) 35 | { 36 | stop("deprecated.") 37 | } 38 | 39 | #random generation function (now using the Rcpp version) 40 | #.f4Random<-function(x,a,b) ifelse( ( x>= 1-(a+1)*b/(a+b) ),1,log( (a*(1-x)) / (a+x) ) /log(b)) 41 | 42 | 43 | 44 | 45 | #density functio 46 | 47 | dmbbefd2<-function(x,a,b,g) 48 | { 49 | stop("deprecated.") 50 | } 51 | 52 | 53 | -------------------------------------------------------------------------------- /tests/test-1inf-shftrncPareto.R: -------------------------------------------------------------------------------- 1 | library(mbbefd) 2 | 3 | #test of shifted truncated pareto distribution 4 | n <- 1e4 5 | 6 | x <- roistpareto(n, 2, p1=1/2) 7 | y <- roistpareto(n, 1/2, p1=1/3) 8 | 9 | #test CDF 10 | z <- 0:10/10 11 | cbind(ecdf(x)(z), poistpareto(z, 2, 1/2)) 12 | 13 | cbind(ecdf(y)(z), poistpareto(z, 1/2, 1/3)) 14 | 15 | #total loss 16 | c(etl(x), tloistpareto(2, 1/2)) 17 | c(etl(y), tloistpareto(1/2, 1/3)) 18 | 19 | #mean 20 | c(mean(x), moistpareto(1, 2, 1/2)) 21 | c(mean(y), moistpareto(1, 1/2, 1/3)) 22 | 23 | 24 | #test EC 25 | cbind(eecf(x)(z), ecoistpareto(z, 2, 1/2)) 26 | cbind(eecf(y)(z), ecoistpareto(z, 1/2, 1/3)) 27 | 28 | 29 | 30 | #plots 31 | n <- 1e2 32 | x <- roistpareto(n, 2, p1=1/2) 33 | y <- roistpareto(n, 1/2, p1=1/3) 34 | 35 | 36 | plot(eecf(x), do.points=FALSE) 37 | v <- seq(0, 1, length=101) 38 | lines(v, ecoistpareto(v, 2, 1/2), lty=3, col="red") 39 | 40 | 41 | plot(eecf(y), do.points=FALSE) 42 | v <- seq(0, 1, length=101) 43 | lines(v, ecoistpareto(v, 1/2, 1/3), lty=3, col="red") 44 | 45 | -------------------------------------------------------------------------------- /tests/test-fit-mbbefdab.R: -------------------------------------------------------------------------------- 1 | library(mbbefd) 2 | library(fitdistrplus) 3 | 4 | n <- 1e3 5 | nboot <- 1000 6 | nboot <- 10 7 | set.seed(123456) 8 | lossrate <- rmbbefd(n, 1/2, 1/10) 9 | 10 | 11 | f1 <- fitDR(lossrate, "mbbefd") 12 | summary(f1) 13 | 14 | #should be similar 15 | f0 <- fitdist(lossrate, "mbbefd", start= list(a=1/4, b=1/4)) 16 | summary(f0) 17 | 18 | 19 | cdfcomp(f1, do.points=FALSE) 20 | qqcomp(f1) 21 | vcov(f1) 22 | 23 | 24 | # llsurface(plot.min=c(0, 0), plot.max=c(2, 1/2), plot.arg=c("a", "b"), obs=lossrate, distr="mbbefd", nlevels=25) 25 | # points(f1$estimate["a"], f1$estimate["b"], pch="+", col="red") 26 | # points(1/2, 1/10, pch="x", col="black") 27 | 28 | b1 <- bootDR(f1, niter=nboot, silent=TRUE) 29 | plot(b1, enhance=TRUE, trueval=c(1/2, 1/10)) 30 | 31 | 32 | f2 <- fitDR(lossrate, "mbbefd", method="tlmme") 33 | summary(f2) 34 | 35 | 36 | 37 | set.seed(123456) 38 | lossrate <- rmbbefd(n, -1/2, 5) 39 | 40 | 41 | f1 <- fitDR(lossrate, "mbbefd") 42 | summary(f1) 43 | 44 | b1 <- bootDR(f1, niter=nboot, silent=TRUE) 45 | plot(b1, enhance=TRUE, trueval=c(-1/2, 5)) 46 | 47 | -------------------------------------------------------------------------------- /tests/test-beaonre.R: -------------------------------------------------------------------------------- 1 | library(mbbefd) 2 | 3 | data(beaonre) 4 | x <- beaonre$ClaimCost/beaonre$SumInsured 5 | 6 | 7 | # #Nelder Mead 8 | # mledist(x[x!=1], "gbeta", start=list(shape0=3.373523e-03, 9 | # shape1=2.913619e+02, shape2=7.198632e+00), control=list(trace=1,REPORT=1)) 10 | # #L-BFGS-B 11 | # mledist(x[x!=1], "gbeta", lower=0, start=list(shape0=3.373523e-03, 12 | # shape1=2.913619e+02, shape2=7.198632e+00), control=list(trace=1, REPORT=1, fnscale=1e-6)) 13 | # 14 | # fitDR(x, "oigbeta", method="mle", control=list(trace=1, REPORT=1)) 15 | # fitDR(x, "MBBEFD", method="mle", control=list(trace=1, REPORT=1)) 16 | 17 | 18 | dlist <- c("oistpareto", "oibeta", "oigbeta", "mbbefd", "MBBEFD") 19 | dlist <- c("oistpareto", "oibeta", "mbbefd", "MBBEFD") 20 | flist <- lapply(dlist, function(d) {print(d); 21 | fitDR(x, d, method="mle")}) 22 | names(flist) <- dlist 23 | 24 | 25 | cdfcomp(flist, do.points=FALSE, leg=dlist) 26 | ppcomp(flist, leg=dlist, fitpch=".", addlegend = FALSE) 27 | legend("bottomright", fill=c("red", "green", "blue", "cyan"), leg=dlist) 28 | 29 | qqcomp(flist, leg=dlist, use.ppoints=TRUE) 30 | -------------------------------------------------------------------------------- /tests/test-asiacom.R: -------------------------------------------------------------------------------- 1 | library(mbbefd) 2 | 3 | data(asiacomrisk) 4 | x <- asiacomrisk$DR 5 | x <- x[!is.na(x)] 6 | 7 | plot(ecdf(x)) 8 | plot(eecf(x)) 9 | etl(x) 10 | 11 | #test optim method 12 | if(FALSE) 13 | { 14 | fitDR(x, "oistpareto", control=list(trace=TRUE)) 15 | 16 | fitDR(x, "oibeta", control=list(trace=TRUE)) 17 | fitDR(x, "oibeta", control=list(trace=TRUE), optim.method="L-BFGS-B") 18 | 19 | fitDR(x, "oigbeta", control=list(trace=TRUE)) 20 | fitDR(x, "oigbeta", control=list(trace=TRUE), optim.method="L-BFGS-B") 21 | fitDR(x, "oigbeta", control=list(trace=TRUE), optim.method="BFGS") 22 | } 23 | 24 | dlist <- c("oiunif", "oistpareto", "oibeta", "oigbeta") 25 | flist <- lapply(dlist, function(d) { 26 | cat("distribution:", d, "\n"); 27 | fitDR(x, d, method="mle", optim.method=ifelse(d=="oigbeta", "BFGS", "default"))}) 28 | names(flist) <- dlist 29 | 30 | 31 | cdfcomp(flist, do.points=FALSE, leg=dlist) 32 | 33 | ppcomp(flist, leg=dlist, fitpch=".", addlegend = FALSE) 34 | legend("bottomright", fill=c("red", "green", "blue", "cyan"), leg=dlist) 35 | 36 | eccomp(flist, leg=dlist, do.points = FALSE) 37 | 38 | qqcomp(flist, leg=dlist, use.ppoints=TRUE) 39 | -------------------------------------------------------------------------------- /R/distr-mbbefdCpp.R: -------------------------------------------------------------------------------- 1 | #' @useDynLib mbbefd 2 | #' @importFrom Rcpp sourceCpp 3 | 4 | #see d, p, q, tl, m functions in distr-mbbefdR*.R 5 | 6 | #random generation 7 | rmbbefdCpp <- function(n, a, b) 8 | { 9 | .rmbbefdC(n, a, b) 10 | } 11 | 12 | rMBBEFDCpp <- function(n, g, b) 13 | { 14 | .rMBBEFDC(n, g, b) 15 | } 16 | 17 | 18 | ### r function MBBEFD(a,b) for users 19 | rmbbefd <- function(n, a, b) 20 | { 21 | #sanity check 22 | stopifnot(is.numeric(n)) 23 | stopifnot(is.numeric(a)) 24 | stopifnot(is.numeric(b)) 25 | 26 | if(min(length(a), length(b), length(n)) <= 0) 27 | return(numeric(0)) 28 | m <- max(length(a), length(b), length(n)) 29 | if(m == 1) 30 | res <- rmbbefdCpp(n, a, b) 31 | else 32 | res <- rmbbefdR(n, a, b) 33 | res 34 | } 35 | 36 | ### r function MBBEFD(g,b) for users 37 | rMBBEFD <- function(n, g, b) 38 | { 39 | #sanity check 40 | stopifnot(is.numeric(n)) 41 | stopifnot(is.numeric(g)) 42 | stopifnot(is.numeric(b)) 43 | 44 | if(min(length(g), length(b), length(n)) <= 0) 45 | return(numeric(0)) 46 | m <- max(length(g), length(b), length(n)) 47 | 48 | if(m == 1) 49 | res <- rMBBEFDCpp(n, g, b) 50 | else 51 | res <- rMBBEFDR(n, g, b) 52 | res 53 | } 54 | 55 | -------------------------------------------------------------------------------- /tests/test-mbbefd-2ndparam-def-prog.R: -------------------------------------------------------------------------------- 1 | library(mbbefd) 2 | 3 | #test of MBBEFD(g,b) distribution 4 | n <- 1e5 5 | 6 | # length(b) > 1 7 | g <- 3/2 8 | b <- c(1:6/3, Inf) 9 | z <- 1/4 10 | cbind(g, b, "gb"=g*b, ecMBBEFD(z, g, b), log( ((g-1)*b+(1-g*b)*b^z)/(1-b) ) / log(g*b) ) 11 | cbind(g, b, "gb"=g*b, pMBBEFD(z, g, b), 1-(1-b)*b^z/((g-1)*b+(1-g*b)*b^z) ) 12 | cbind(g, b, "gb"=g*b, dMBBEFD(z, g, b), -(1-b)*log(b)*(g-1)*b^(1+z)/((g-1)*b+(1-g*b)*b^z)^2 ) 13 | cbind(g, b, "gb"=g*b, tlMBBEFD(g, b), 1/g) 14 | 15 | # length(x) > 1 16 | g <- 3/2 17 | b <- 1/3 18 | z <- seq(-1/2, 3/2, length=21) 19 | cbind(z, ecMBBEFD(z, g, b), log( ((g-1)*b+(1-g*b)*b^z)/(1-b) ) / log(g*b) ) 20 | cbind(z, pMBBEFD(z, g, b), 1-(1-b)*b^z/((g-1)*b+(1-g*b)*b^z) ) 21 | cbind(z, dMBBEFD(z, g, b), -(1-b)*log(b)*(g-1)*b^(1+z)/((g-1)*b+(1-g*b)*b^z)^2 ) 22 | cbind(z, qMBBEFD(z, g, b)) 23 | 24 | # length(a,b,x) > 1 25 | g <- 2:4 26 | b <- 1/2:5 27 | z <- 1/2:13 28 | g <- rep_len(g, length(z)) 29 | b <- rep_len(b, length(z)) 30 | 31 | cbind(z, ecMBBEFD(z, g, b), log( ((g-1)*b+(1-g*b)*b^z)/(1-b) ) / log(g*b) ) 32 | cbind(z, pMBBEFD(z, g, b), 1-(1-b)*b^z/((g-1)*b+(1-g*b)*b^z) ) 33 | cbind(z, dMBBEFD(z, g, b), -(1-b)*log(b)*(g-1)*b^(1+z)/((g-1)*b+(1-g*b)*b^z)^2 ) 34 | cbind(g, b, "gb"=g*b, tlMBBEFD(g, b), 1/g) 35 | -------------------------------------------------------------------------------- /man/beaonre.Rd: -------------------------------------------------------------------------------- 1 | \name{beaonre} 2 | \alias{beaonre} 3 | 4 | \docType{data} 5 | \title{ AON Re Belgian dataset } 6 | 7 | \description{ 8 | The dataset was collected by the reinsurance broker 9 | AON Re Belgium and comprise 1,823 fire losses for which the building 10 | type and the sum insured are available. 11 | 12 | 13 | 14 | } 15 | 16 | \usage{ 17 | data(beaonre) 18 | } 19 | 20 | \format{ 21 | \code{beaonre} contains three columns and 1823 rows: 22 | \describe{ 23 | \item{\code{BuildType}}{The building type either A, B, C, D, E or F.} 24 | \item{\code{ClaimCost}}{The loss amount in thousand of Danish Krone (DKK).} 25 | \item{\code{SumInsured}}{The sum insured in thousand of Danish Krone (DKK).} 26 | } 27 | 28 | } 29 | 30 | \references{ 31 | Dataset used in Beirlant, Dierckx, Goegebeur and Matthys (1999), 32 | \emph{Tail index estimation and an exponential regression model}, 33 | Extremes 2, 177-200, 34 | \doi{10.1023/A:1009975020370}. 35 | 36 | 37 | } 38 | 39 | \examples{ 40 | 41 | # (1) load of data 42 | # 43 | data(beaonre) 44 | 45 | # (2) plot and description of data 46 | # 47 | 48 | boxplot(ClaimCost ~ BuildType, data=beaonre, log="y", 49 | xlab="Building type", ylab="Claim size", main="AON Re Belgium data") 50 | 51 | 52 | 53 | } 54 | 55 | \keyword{ datasets } 56 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: mbbefd 2 | Type: Package 3 | Title: Maxwell Boltzmann Bose Einstein Fermi Dirac Distribution and 4 | Destruction Rate Modelling 5 | Version: 0.8.14 6 | Authors@R: c( 7 | person("Christophe", "Dutang", role = c("aut", "cre"), email = "dutangc@gmail.com", comment = c(ORCID = "0000-0001-6732-1501")), 8 | person("Giorgio", "Spedicato", role = "aut", email = "spedicato_giorgio@yahoo.it", comment = c(ORCID = "0000-0002-0315-8888")), 9 | person("Markus", "Gesmann", role = "ctb", email = "markus.gesmann@gmail.com")) 10 | Description: Distributions that are typically used for exposure rating in 11 | general insurance, in particular to price reinsurance contracts. 12 | The vignette shows code snippets to fit the distribution to 13 | empirical data. See, e.g., Bernegger (1997) 14 | freely available on-line. 15 | License: GPL-2 16 | Depends: R (>= 3.6), fitdistrplus (>= 1.1-4), alabama, Rcpp (>= 0.12.18) 17 | ByteCompile: yes 18 | Suggests: testthat, pander, rmarkdown, knitr, lattice 19 | LinkingTo: Rcpp 20 | Imports: utils, actuar, MASS 21 | URL: https://github.com/spedygiorgio/mbbefd 22 | BugReports: https://github.com/spedygiorgio/mbbefd/issues 23 | VignetteBuilder: knitr 24 | SystemRequirements: GNU make 25 | NeedsCompilation: yes 26 | RoxygenNote: 6.0.1 27 | -------------------------------------------------------------------------------- /R/distr-1infl-genbeta.R: -------------------------------------------------------------------------------- 1 | #d, p, q, r function for one-inflated beta distribution 2 | 3 | 4 | doigbeta <- function(x, shape0, shape1, shape2, p1, log=FALSE) 5 | { 6 | doifun(x=x, dfun=dgbeta, p1=p1, log=log, shape1=shape1, shape2=shape2, shape0=shape0) 7 | } 8 | 9 | poigbeta <- function(q, shape0, shape1, shape2, p1, lower.tail = TRUE, log.p = FALSE) 10 | { 11 | poifun(q=q, pfun=pgbeta, p1=p1, lower.tail=lower.tail, log.p=log.p, shape1=shape1, shape2=shape2, shape0=shape0) 12 | } 13 | 14 | qoigbeta <- function(p, shape0, shape1, shape2, p1, lower.tail = TRUE, log.p = FALSE) 15 | { 16 | qoifun(p=p, qfun=qgbeta, p1=p1, lower.tail=lower.tail, log.p=log.p, shape1=shape1, shape2=shape2, shape0=shape0) 17 | } 18 | 19 | roigbeta <- function(n, shape0, shape1, shape2, p1) 20 | { 21 | roifun(n=n, rfun=rgbeta, p1=p1, shape1=shape1, shape2=shape2, shape0=shape0) 22 | } 23 | 24 | ecoigbeta <- function(x, shape0, shape1, shape2, p1) 25 | { 26 | ecoifun(x=x, ecfun=ecgbeta, mfun=mgbeta, p1=p1, shape1=shape1, shape2=shape2, shape0=shape0) 27 | } 28 | 29 | moigbeta <- function(order, shape0, shape1, shape2, p1) 30 | { 31 | moifun(order=order, mfun=mgbeta, p1=p1, shape1=shape1, shape2=shape2, shape0=shape0) 32 | } 33 | 34 | tloigbeta <- function(shape0, shape1, shape2, p1) 35 | { 36 | tloifun(p1=p1, shape1=shape1, shape2=shape2, shape0=shape0) 37 | } 38 | 39 | 40 | -------------------------------------------------------------------------------- /R/distr-1infl-beta.R: -------------------------------------------------------------------------------- 1 | #d, p, q, r function for one-inflated beta distribution 2 | 3 | 4 | doibeta <- function(x, shape1, shape2, p1, ncp=0, log=FALSE) 5 | { 6 | doifun(x=x, dfun=dbeta, p1=p1, log=log, shape1=shape1, shape2=shape2, ncp=ncp) 7 | } 8 | 9 | poibeta <- function(q, shape1, shape2, p1, ncp=0, lower.tail = TRUE, log.p = FALSE) 10 | { 11 | poifun(q=q, pfun=pbeta, p1=p1, lower.tail = lower.tail, log.p = log.p, shape1=shape1, shape2=shape2, ncp=ncp) 12 | } 13 | 14 | qoibeta <- function(p, shape1, shape2, p1, ncp=0, lower.tail = TRUE, log.p = FALSE) 15 | { 16 | qoifun(p=p, qfun=qbeta, p1=p1, lower.tail = lower.tail, log.p = log.p, shape1=shape1, shape2=shape2, ncp=ncp) 17 | } 18 | 19 | roibeta <- function(n, shape1, shape2, p1, ncp=0) 20 | { 21 | roifun(n=n, rfun=rbeta, p1=p1, shape1=shape1, shape2=shape2, ncp=ncp) 22 | } 23 | 24 | ecoibeta <- function(x, shape1, shape2, p1, ncp=0) 25 | { 26 | if(ncp != 0) 27 | stop("not yet implemented.") 28 | ecoifun(x=x, ecfun=ecbeta, mfun=mbeta, p1=p1, shape1=shape1, shape2=shape2) 29 | } 30 | 31 | moibeta <- function(order, shape1, shape2, p1, ncp=0) 32 | { 33 | if(ncp != 0) 34 | stop("not yet implemented.") 35 | moifun(order=order, mfun=mbeta, p1=p1, shape1=shape1, shape2=shape2) 36 | } 37 | 38 | 39 | tloibeta <- function(shape1, shape2, p1, ncp=0) 40 | { 41 | tloifun(p1=p1, shape1=shape1, shape2=shape2, ncp=ncp) 42 | } 43 | -------------------------------------------------------------------------------- /man/itagradscore.Rd: -------------------------------------------------------------------------------- 1 | \name{itagradescore} 2 | \alias{itagradescore} 3 | 4 | \docType{data} 5 | \title{ Italian grade scores } 6 | 7 | \description{ 8 | This dataset contains scores of an university admission test. 9 | The total score is subdivided into four areas (Italian, English, abstract reasoning, science). 10 | Each subitem can have a point of pass at the end. 11 | 12 | } 13 | 14 | \usage{ 15 | data(itagradescore) 16 | } 17 | 18 | \format{ 19 | \code{itagradescore} contains 10 columns: 20 | \describe{ 21 | \item{\code{Number}}{a numeric for the record number.} 22 | \item{\code{ID}}{a factor for the identification code.} 23 | \item{\code{Correct}}{A score of correct answers.} 24 | \item{\code{Wrong}}{A score of wrong answers.} 25 | \item{\code{Null}}{A score of null answers.} 26 | \item{\code{ItalianLanguage}}{A score for the Italian language test.} 27 | \item{\code{EnglishLanguage}}{A score for the English language test.} 28 | \item{\code{LogicalReasoning}}{A score for the logic test.} 29 | \item{\code{Science}}{A score for the science test.} 30 | \item{\code{TotalScore}}{The sum of the four scores (i.e. four previous columns).} 31 | } 32 | 33 | 34 | } 35 | 36 | \source{ 37 | Internal 38 | } 39 | 40 | 41 | \examples{ 42 | 43 | # (1) load of data 44 | # 45 | data(itagradescore) 46 | dim(itagradescore) 47 | 48 | } 49 | 50 | \keyword{ datasets } 51 | -------------------------------------------------------------------------------- /tests/test-1inf-GB1.R: -------------------------------------------------------------------------------- 1 | library(mbbefd) 2 | 3 | #test of GB1 distribution 4 | 5 | #integral of the improper density 6 | integrate(doigbeta, 0, 1, shape0=1, shape1=3, shape2=3/2, p1=1/3) 7 | integrate(doigbeta, 0, 1, shape0=1/2, shape1=3, shape2=3/2, p1=1/3) 8 | integrate(doigbeta, 0, 1, shape0=2, shape1=3, shape2=3/2, p1=2/3) 9 | 10 | 11 | #RNG 12 | n <- 1e4 13 | x <- roigbeta(n, shape0=2, shape1=3, shape2=3/2, p1=1/3) 14 | y <- roigbeta(n, shape0=pi, shape1=3, shape2=3/2, p1=2/3) 15 | 16 | c(etl(x), tloigbeta(shape0=2, shape1=3, shape2=3/2, p1=1/3)) 17 | c(etl(y), tloigbeta(shape0=pi, shape1=3, shape2=3/2, p1=2/3)) 18 | 19 | #test CDF 20 | z <- 0:10/10 21 | cbind(ecdf(x)(z), poigbeta(z, shape0=2, shape1=3, shape2=3/2, p1=1/3)) 22 | cbind(ecdf(y)(z), poigbeta(z, shape0=pi, shape1=3, shape2=3/2, p1=2/3)) 23 | 24 | 25 | #mean 26 | c(mean(x), moigbeta(1, shape0=2, shape1=3, shape2=3/2, p1=1/3)) 27 | c(mean(y), moigbeta(1, shape0=pi, shape1=3, shape2=3/2, p1=2/3)) 28 | 29 | #raw moment 30 | for(i in 2:4) 31 | { 32 | cat("E(X^", i, ")\n", sep="") 33 | print(c(mean(x^i), moigbeta(i, shape0=2, shape1=3, shape2=3/2, p1=1/3))) 34 | print(c(mean(y^i), moigbeta(i, shape0=pi, shape1=3, shape2=3/2, p1=2/3))) 35 | } 36 | 37 | 38 | #test EC 39 | cbind(eecf(x)(z), ecoigbeta(z, shape0=2, shape1=3, shape2=3/2, p1=1/3)) 40 | 41 | cbind(eecf(y)(z), ecoigbeta(z, shape0=pi, shape1=3, shape2=3/2, p1=2/3)) 42 | 43 | 44 | 45 | 46 | -------------------------------------------------------------------------------- /tests/check-formula-variance.R: -------------------------------------------------------------------------------- 1 | #test integral for second order moment 2 | 3 | f <- function(x, a, b) 4 | { 5 | if(a == 0) 6 | return(x*log(b)) 7 | if(b == 1) 8 | return(rep(log(a+1), length(x))) 9 | log(a+b^x) 10 | } 11 | 12 | 13 | a <- -1/2 14 | sapply(1:3+1/2, function(b) 15 | c(a=a, b=b, check=integrate(f, 0, 1, a=a, b=b)$value, th=mbbefd:::gendilog(a, b)) 16 | ) 17 | 18 | a <- 0 19 | sapply(1:3, function(b) 20 | c(a=a, b=b, check=integrate(f, 0, 1, a=a, b=b)$value, th=mbbefd:::gendilog(a, b)) 21 | ) 22 | 23 | a <- 1 24 | sapply(1:3, function(b) 25 | c(a=a, b=b, check=integrate(f, 0, 1, a=a, b=b)$value, th=mbbefd:::gendilog(a, b, checkparam=FALSE)) 26 | ) 27 | 28 | a <- 2 29 | sapply(1:3, function(b) 30 | c(a=a, b=b, check=integrate(f, 0, 1, a=a, b=b)$value, th=mbbefd:::gendilog(a, b, checkparam=FALSE)) 31 | ) 32 | 33 | a <- 3 34 | sapply(1:3, function(b) 35 | c(a=a, b=b, check=integrate(f, 0, 1, a=a, b=b)$value, th=mbbefd:::gendilog(a, b, checkparam=FALSE)) 36 | ) 37 | 38 | 39 | vartheo <- function(a, b) 40 | { 41 | EX <- mmbbefd(1, a, b) 42 | 43 | mmbbefd(2, a, b) - EX^2 44 | } 45 | 46 | require(mbbefd) 47 | n <- 1e4 48 | x <- rmbbefd(n, 2, 1/2) 49 | c(var(x), vartheo(2, 1/2)) 50 | 51 | x <- rmbbefd(n, -1/2, 3) 52 | c(var(x), vartheo(-1/2, 3)) 53 | 54 | x <- rmbbefd(n, -1/2, 2) 55 | c(var(x), vartheo(-1/2, 2)) 56 | 57 | x <- rmbbefd(n, 2, 1/5) 58 | c(var(x), vartheo(2, 1/5)) 59 | 60 | -------------------------------------------------------------------------------- /man/exposureCurve.Rd: -------------------------------------------------------------------------------- 1 | \name{exposureCurve} 2 | \alias{exposureCurve} 3 | \alias{ecbeta} 4 | \alias{ecunif} 5 | 6 | \title{ 7 | Exposure curves for the beta and the uniform distributions. 8 | } 9 | \description{ 10 | An exposure curve is defined between x between 0 and 1 and represents the ratio of the limited expected value to unlimited expected value. 11 | } 12 | \usage{ 13 | ecbeta(x, shape1, shape2) 14 | ecunif(x, min = 0, max =1) 15 | 16 | } 17 | \arguments{ 18 | 19 | \item{x}{ 20 | x value, percentage of damage to total loss 21 | } 22 | \item{shape1, shape2}{ 23 | parameters for the beta distribution. 24 | } 25 | \item{min, max}{ 26 | parameters for the uniform distribution. 27 | } 28 | } 29 | \details{ 30 | \code{ecbeta}, \code{ecunif} is the theoretical exposure curve function for beta and uniform distribution. 31 | 32 | } 33 | \value{ 34 | A numeric value 35 | } 36 | \references{ 37 | BERNEGGER, STEFAN (1997). 38 | \emph{The Swiss Re Exposure Curves And The MBBEFD Distribution Class}, 39 | ASTIN Bulletin, 27(1), pp99-111, \doi{https://doi.org/10.2143/AST.27.1.563208}. 40 | } 41 | \author{ 42 | Giorgio Spedicato, 43 | Christophe Dutang 44 | } 45 | \seealso{ 46 | \code{ecmbbefd} and \code{ecMBBEFD} are implemented in \code{\link{mbbefd-distr}}. 47 | See also \code{\link{Uniform}}, \code{\link{Beta}}, \code{\link{swissRe}}. 48 | } 49 | \examples{ 50 | 51 | x <- 0.2 52 | ecbeta(x, 2, 3) 53 | ecunif(x) 54 | 55 | 56 | } 57 | -------------------------------------------------------------------------------- /tests/test-smokedfish.R: -------------------------------------------------------------------------------- 1 | library(mbbefd) 2 | library(fitdistrplus) 3 | data(smokedfish) 4 | 5 | #normed data 6 | listeria <- apply(smokedfish, 1, mean, na.rm=TRUE) / 100 7 | #purety rate 8 | set.seed(1234) 9 | x <- pmin(pmax(jitter(1-listeria, amount=.2), 0.01), 1) 10 | 11 | #mledist(x[x!=1], "stpareto", start=list(a=2), optim.method="Nelder", control=list(trace=1, REPORT=1), lower=.01) 12 | 13 | #, control=list(trace=1, REPORT=1) 14 | flist <- list( 15 | fitDR(x, "oistpareto", start=list(a=0.01), optim.method="Nelder"), 16 | fitDR(x, "oibeta"), fitDR(x, "oigbeta")) 17 | names(flist) <- dlist <- c("oistpareto", "oibeta", "oigbeta") 18 | 19 | gof1 <- gofstat(flist) 20 | 21 | mm <- rbind(KS = gof1$ks, CvM = gof1$cvm, AD = gof1$ad, AIC = gof1$aic, BIC = gof1$bic) 22 | rownames(mm) <- c("Kolmogorov-Smirnov statistic", "Cramer-von Mises statistic", 23 | "Anderson-Darling statistic", "Aikake's Information Criterion", "Bayesian Information Criterion") 24 | 25 | 26 | cdfcomp(flist, do.points=FALSE, leg=dlist, addlegend = FALSE, fitlwd=1.5, main="Emp./theo. CDFs - ecotoxicology") 27 | legend("topleft", col=c("red", "green", "blue"), leg=dlist, lty=1:3, lwd=2, bty="n") 28 | 29 | #log scale 30 | par(mar=c(4,4,2,1)) 31 | cdfcomp(flist, do.points=FALSE, leg=dlist, xlogscale = TRUE, addlegend = FALSE, fitlwd=1.5, main="Emp./theo. CDFs - ecotoxicology") 32 | legend("topleft", col=c("red", "green", "blue"), leg=dlist, lty=1:3, lwd=2, bty="n") 33 | -------------------------------------------------------------------------------- /R/data-documentData-old.R: -------------------------------------------------------------------------------- 1 | # ciao<-read.table(file="Z:/aon.txt",header=FALSE,sep=" ") 2 | # names(ciao)<-c("class","loss","sumInsured") 3 | # aon<-transform(ciao, sumInsured=sumInsured*1000) 4 | # devtools::use_data(aon) 5 | 6 | #' AON Re Belgium data. 7 | #' 8 | #' A dataset containing losses and sum insured for building property damage of AON Re Belgium portfolio. 9 | #' Claims are split by building category. 10 | #' 11 | #' @format A data frame with 1823 rows and 3 variables: 12 | #' \describe{ 13 | #' \item{class}{building category} 14 | #' \item{loss}{loss size} 15 | #' \item{sumInsured}{sum insured} 16 | #' ... 17 | #' } 18 | #' @source \url{http://lstat.kuleuven.be/Wiley/} 19 | "aon" 20 | 21 | # ciao<-read.table(file="Z:/lossdata.txt",header=FALSE,sep="\t") 22 | # names(ciao)<-c("loss","alae","limit","censored") 23 | # loss<-ciao 24 | # devtools::use_data(loss) 25 | 26 | #' Loss-ALAE data of Freez and Valdez 27 | #' 28 | #' A dataset containing losses (claim amount), alae and policy limit. 29 | #' Also censoring information is reported (actual claim amount to exceed policy limit). 30 | #' 31 | #' @format A data frame with 1500 rows and 4 variables: 32 | #' \describe{ 33 | #' \item{loss}{actual claim amount for the claim} 34 | #' \item{alae}{allocated loss adjustment expense for the claim} 35 | #' \item{limit}{policy limit} 36 | #' \item{censored}{0 not censored, 1 censored} 37 | #' ... 38 | #' } 39 | #' @source \url{http://lstat.kuleuven.be/Wiley/} 40 | "loss" 41 | -------------------------------------------------------------------------------- /R/RcppExports.R: -------------------------------------------------------------------------------- 1 | # Generated by using Rcpp::compileAttributes() -> do not edit by hand 2 | # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 3 | 4 | #' random number generation - 1st param 5 | #' 6 | #' \code{rmbbefdC} generates random variates distribution parameters a and b 7 | #' 8 | #' @param n: the number of random variates 9 | #' @param a: first shape parameter 10 | #' @param b: second shape parameter 11 | #' 12 | #' @return a vector of real values 13 | #' 14 | #' @example 15 | #' 16 | #' rmbbefdC2(n=10, a=.2, b=.05) 17 | NULL 18 | 19 | #' random number generation - 2nd param 20 | #' 21 | #' \code{rMBBEFDC} generates random variates distribution parameters g and b 22 | #' 23 | #' @param n: the number of random variates 24 | #' @param g: first shape parameter 25 | #' @param b: second shape parameter 26 | #' 27 | #' @return a vector of real values 28 | #' 29 | #' @example 30 | #' 31 | #' rMBBEFDC2(n=10, g=2, b=.05) 32 | NULL 33 | 34 | #' Get a parameter known g and b 35 | #' 36 | #' \code{g2a} returns the a parameter known g and b 37 | #' 38 | #' @param g the g parameter 39 | #' @param b the b parameter 40 | #' 41 | #' @return a real value 42 | #' 43 | #' @examples 44 | #' 45 | #' g2a(10,2) 46 | #' 47 | #' @export 48 | g2a <- function(g, b) { 49 | .Call(`_mbbefd_g2a`, g, b) 50 | } 51 | 52 | .rmbbefdC <- function(n, a, b) { 53 | .Call(`_mbbefd_rmbbefdC`, n, a, b) 54 | } 55 | 56 | .rMBBEFDC <- function(n, g, b) { 57 | .Call(`_mbbefd_rMBBEFDC`, n, g, b) 58 | } 59 | 60 | -------------------------------------------------------------------------------- /tests/test-lossalae.R: -------------------------------------------------------------------------------- 1 | library(mbbefd) 2 | 3 | data(lossalaefull) 4 | x <- lossalaefull$Loss/lossalaefull$Limit 5 | 6 | 7 | # fitDR(x, "oigbeta", method="mle", control=list(trace=1, REPORT=1)) 8 | 9 | dlist <- c("oistpareto", "oibeta", "oigbeta") 10 | flist <- lapply(dlist, function(d) {print(d); 11 | fitDR(x, d, method="mle")}) 12 | names(flist) <- dlist 13 | 14 | gof1 <- gofstat(flist) 15 | 16 | mm <- rbind(KS = gof1$ks, CvM = gof1$cvm, AD = gof1$ad, AIC = gof1$aic, BIC = gof1$bic) 17 | rownames(mm) <- c("Kolmogorov-Smirnov statistic", "Cramer-von Mises statistic", 18 | "Anderson-Darling statistic", "Aikake's Information Criterion", "Bayesian Information Criterion") 19 | 20 | 21 | cdfcomp(flist, do.points=FALSE, leg=dlist, addlegend = FALSE, fitlwd=1.5, main="Emp./theo. CDFs - insurance") 22 | legend("topleft", col=c("red", "green", "blue"), leg=dlist, lty=1:3, lwd=2, bty="n") 23 | 24 | 25 | par(mar=c(4,4,2,1)) 26 | cdfcomp(flist, do.points=FALSE, leg=dlist, xlogscale = TRUE, addlegend = FALSE, fitlwd=1.5, main="Emp./theo. CDFs - insurance") 27 | legend("topleft", col=c("red", "green", "blue"), leg=dlist, lty=1:3, lwd=2, bty="n") 28 | 29 | eccomp(flist, leg=dlist, do.points = FALSE, addlegend = FALSE, lwd=1.5) 30 | legend("topleft", col=c("red", "green", "blue"), leg=dlist, lty=1:3, lwd=2, bty="n") 31 | 32 | ppcomp(flist, leg=dlist, fitpch=".", addlegend = FALSE) 33 | legend("bottomright", fill=c("red", "green", "blue", "cyan", "purple"), leg=dlist) 34 | 35 | 36 | qqcomp(flist, leg=dlist, use.ppoints=TRUE) 37 | -------------------------------------------------------------------------------- /tests/test-mbbefd-2ndparam-grLL.R: -------------------------------------------------------------------------------- 1 | library(mbbefd) 2 | 3 | g1 <- function(g, b, x) 4 | { 5 | denom1 <- (g-1)*b^(1-x)+1-g*b 6 | num1 <- (b-1)*log(b)*b^(1-x) -2*(b-1)*(g-1)*log(b)*b^(1-x)*(b^(1-x)-b)/denom1 7 | num1/denom1^2 8 | } 9 | G1 <- function(x, g, b) 10 | { 11 | sapply(g, function(y) integrate(g1, lower=1, upper=y, b=b, x=x)$value) 12 | } 13 | 14 | 15 | G1(1/2, 3:10, 2) 16 | sapply(3:10, function(g) dMBBEFD(1/2, g, 2)) 17 | 18 | 19 | g2 <- function(b, g, x) 20 | { 21 | denom1 <- (g-1)*b^(1-x)+1-g*b 22 | num1 <- (g-1)*log(b)*b^(1-x) + (b-1)*(g-1)*b^(-x) 23 | num2 <- (b-1)*(g-1)*log(b)*(1-x)*b^(-x) 24 | num3 <- - 2*(b-1)*(g-1)*log(b)*b^(1-x) *((g-1)*(1-x)*b^(-x)-g)/denom1 25 | (num1+num2+num3)/denom1^2 26 | } 27 | 28 | g21 <- function(b, g, x) 29 | { 30 | U <- (g-1)*b^(1-x)+1-g*b 31 | Uprimex <- -(g-1)*log(b)*b^(1-x) 32 | T1 <- -(1-b)*(1/b/log(b) - (1-x)/b) 33 | T2 <- 2*(1-b)/U*( (g-1)*(1-x)*b^(-x) -g ) 34 | -Uprimex/U^2*(1 + T1 + T2) 35 | } 36 | 37 | 38 | 39 | G2 <- function(x, g, b) 40 | { 41 | sapply(b, function(y) integrate(g2, lower=1, upper=y, g=g, x=x)$value) 42 | } 43 | 44 | 45 | G21 <- function(x, g, b) 46 | { 47 | sapply(b, function(y) integrate(g21, lower=1, upper=y, g=g, x=x)$value) 48 | } 49 | 50 | G22 <- function(x, g, b) 51 | { 52 | sapply(b, function(y) try(integrate(g22, lower=1.1, upper=y, g=g, x=x)$value)) 53 | } 54 | 55 | x0 <- 1/3 56 | cbind(G2(x0, 3, 2:10), 57 | G21(x0, 3, 2:10), 58 | G22(x0, 3, 2:10), 59 | sapply(2:10, function(b) dMBBEFD(x0, 3, b)) 60 | ) 61 | 62 | -------------------------------------------------------------------------------- /tests/test-1inf-mean.R: -------------------------------------------------------------------------------- 1 | require(mbbefd) 2 | 3 | #check of expectation for oi distribution 4 | n <- 1e4 5 | 6 | probs <- c(1/(2:9)) 7 | 8 | sapply(probs, function(p) 9 | { 10 | x <- roiunif(n, p) 11 | c(mean(x), mbbefd:::tmean1(doiunif, p1=p), 12 | mbbefd:::tmean2(poiunif, p1=p), mbbefd:::tmean3(ecoiunif, p1=p)) 13 | } 14 | ) 15 | 16 | 17 | 18 | sapply(probs, function(p) 19 | { 20 | x <- roistpareto(n, a=2, p) 21 | c(mean(x), mbbefd:::tmean1(doistpareto, a=2, p1=p), 22 | mbbefd:::tmean2(poistpareto, a=2, p1=p), mbbefd:::tmean3(ecoistpareto, a=2, p1=p)) 23 | } 24 | ) 25 | 26 | 27 | 28 | 29 | sapply(probs, function(p) 30 | { 31 | x <- roibeta(n, shape1=2, shape2=3, p) 32 | c(mean(x), mbbefd:::tmean1(doibeta, shape1=2, shape2=3, p1=p), 33 | mbbefd:::tmean2(poibeta, shape1=2, shape2=3, p1=p), 34 | mbbefd:::tmean3(ecoibeta, shape1=2, shape2=3, p1=p)) 35 | } 36 | ) 37 | 38 | 39 | sapply(probs, function(p) 40 | { 41 | x <- roigbeta(n, shape0=pi, shape1=2, shape2=3, p) 42 | c(mean(x), mbbefd:::tmean1(doigbeta, shape0=pi, shape1=2, shape2=3, p1=p), 43 | mbbefd:::tmean2(poigbeta, shape0=pi, shape1=2, shape2=3, p1=p), 44 | mbbefd:::tmean3(ecoigbeta, shape0=pi, shape1=2, shape2=3, p1=p)) 45 | } 46 | ) 47 | 48 | 49 | x <- rmbbefd(n, a=2, b=1/2) 50 | c(mean(x), mbbefd:::tmean1(dmbbefd, a=2, b=1/2), 51 | mbbefd:::tmean2(pmbbefd, a=2, b=1/2), 52 | mbbefd:::tmean3(ecmbbefd, a=2, b=1/2)) 53 | 54 | 55 | x <- rmbbefd(n, a=-1/2, b=3) 56 | c(mean(x), mbbefd:::tmean1(dmbbefd, a=-1/2, b=3), 57 | mbbefd:::tmean2(pmbbefd, a=-1/2, b=3), 58 | mbbefd:::tmean3(ecmbbefd, a=-1/2, b=3)) 59 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Maxwell Boltzmann Bose Einstein Fermi Dirac Distribution and Destruction Rate Modelling 2 | 3 | [![CRAN-Version](https://www.r-pkg.org/badges/version/mbbefd)](https://cran.r-project.org/package=mbbefd) 4 | [![CRAN-Downloads](https://cranlogs.r-pkg.org/badges/last-month/mbbefd)](https://cran.r-project.org/package=mbbefd) 5 | [![CRAN-checks](https://badges.cranchecks.info/summary/mbbefd.svg)](https://cran.r-project.org/web/checks/check_results_mbbefd.html) 6 | [![License: GPL 7 | v3](https://img.shields.io/badge/License-GPLv3-blue.svg)](https://www.gnu.org/licenses/gpl-3.0) 8 | [![Git-Version](https://img.shields.io/badge/devel%20version-0.8.14-red.svg)](https://github.com/spedygiorgio/mbbefd) 9 | 10 | MBBEFD provides additional distributions to R, such as the MBBEFD and 11 | shifted truncated Pareto as well as functions to handle destruction rate 12 | models. 13 | 14 | The distributions and models of the mbbefd package are particular 15 | popular for understanding and pricing risk in general insurance and 16 | reinsurance and are used for exposure rating, benchmarking and curve 17 | fitting. 18 | 19 | ## Install the current release from CRAN: 20 | 21 | ``` r 22 | install.packages('mbbefd') 23 | ``` 24 | 25 | ## Install the development version from GitHub: 26 | 27 | ``` r 28 | devtools::install_github('spedygiorgio/mbbefd') 29 | ``` 30 | 31 | ## Documentation 32 | 33 | Please find helps in the vignette and 34 | 35 | ``` 36 | library(mbbefd) 37 | help("mbbefd-package") 38 | ``` 39 | 40 | ## Citation 41 | 42 | If you use `mbbefd`, you should cite:
Christophe Dutang, Giorgio 43 | Spedicato (2025). *mbbefd: Maxwell Boltzmann Bose Einstein Fermi Dirac 44 | Distribution and Destruction Rate Modelling.* R package. 45 | -------------------------------------------------------------------------------- /man/distr-sfttrncPareto.Rd: -------------------------------------------------------------------------------- 1 | \name{stpareto} 2 | \alias{stpareto} 3 | \alias{dstpareto} 4 | \alias{pstpareto} 5 | \alias{qstpareto} 6 | \alias{rstpareto} 7 | \alias{mstpareto} 8 | \alias{ecstpareto} 9 | 10 | \title{ 11 | The shifted truncated Pareto distribution 12 | } 13 | \description{ 14 | These functions perform probabilistic analysis as well as random sampling on the shifted truncated Pareto distribution. 15 | 16 | } 17 | \usage{ 18 | 19 | dstpareto(x, a, log=FALSE) 20 | pstpareto(q, a, lower.tail = TRUE, log.p = FALSE) 21 | qstpareto(p, a, lower.tail = TRUE, log.p = FALSE) 22 | rstpareto(n, a) 23 | mstpareto(order, a) 24 | ecstpareto(x, a) 25 | 26 | 27 | } 28 | 29 | \arguments{ 30 | \item{x, q}{ 31 | vector of quantiles. 32 | } 33 | \item{p}{ 34 | vector of probabilities. 35 | } 36 | \item{n}{ 37 | number of observations. If \code{length(n) > 1}, the length is take to be the number required. 38 | } 39 | \item{order}{ 40 | order of the raw moment. 41 | } 42 | \item{a}{ 43 | shape parameter. 44 | } 45 | \item{log, log.p}{ 46 | logical; if \code{TRUE}, probabilities \code{p} are given as log(p). 47 | } 48 | \item{lower.tail}{ 49 | logical; if \code{TRUE} (default), probabilities are \eqn{P[X <= x]}, otherwise, \eqn{P[X> x]}. 50 | } 51 | 52 | 53 | } 54 | \details{ 55 | The distribution is based on the Pareto 2 truncated at 1. The distribution function is given 56 | by \eqn{P(X<=x) = (1-(x+1)^(-a))/(1-2^(-a)).} 57 | 58 | } 59 | \value{ 60 | A numeric value or a vector. 61 | } 62 | 63 | \author{ 64 | Dutang Christophe 65 | } 66 | \seealso{ 67 | \code{\link{mbbefd-distr}}, \code{\link{exposureCurve}} 68 | } 69 | \examples{ 70 | 71 | #density 72 | curve(dstpareto(x, 3)) 73 | 74 | #cdf 75 | curve(pstpareto(x, 3)) 76 | } 77 | \keyword{distribution} 78 | -------------------------------------------------------------------------------- /R/distr-shftrncPareto.R: -------------------------------------------------------------------------------- 1 | #d, p, q, r function for shifted truncated Pareto distribution 2 | 3 | #should it be dstpareto01? 4 | dstpareto <- function(x, a, log=FALSE) 5 | { 6 | if(!(a > 0)) 7 | return(rep(NaN, length(x))) 8 | 9 | res <- a * (x+1)^(-a-1)/(1 - 2^(-a)) 10 | res[x > 1] <- 0 11 | res[x < 0] <- 0 12 | 13 | if(log) 14 | res <- log(res) 15 | res 16 | } 17 | 18 | pstpareto <- function(q, a, lower.tail = TRUE, log.p = FALSE) 19 | { 20 | if(!(a > 0)) 21 | return(rep(NaN, length(q))) 22 | 23 | res <- (1 - (q+1)^(-a))/(1-2^(-a)) 24 | res[q >= 1] <- 1 25 | res[q <= 0] <- 0 26 | 27 | if(!lower.tail) 28 | res <- 1-res 29 | if(log.p) 30 | res <- log(res) 31 | 32 | res 33 | } 34 | 35 | 36 | qstpareto <- function(p, a, lower.tail = TRUE, log.p = FALSE) 37 | { 38 | if(!(a > 0)) 39 | return(rep(NaN, length(p))) 40 | 41 | if(!lower.tail) 42 | p <- 1-p 43 | if(log.p) 44 | p <- exp(p) 45 | 46 | res <- (1-p*(1-2^(-a)))^(-1/a) - 1 47 | res[p < 0 | p > 1] <- NaN 48 | 49 | res 50 | } 51 | 52 | rstpareto <- function(n, a) 53 | { 54 | n <- ifelse(length(n)>1, length(n), n) 55 | if(!(a > 0)) 56 | return(rep(NaN, n)) 57 | qstpareto(runif(n, 0, 1), a) 58 | } 59 | 60 | 61 | ecstpareto <- function(x, a) 62 | { 63 | if(!(a > 0)) 64 | return(rep(NaN, length(x))) 65 | 66 | if(a == 1) 67 | { 68 | res <- (2*log(x+1) - x)/(2*log(2) - 1) 69 | }else 70 | { 71 | res <- ((x+1)^(-a+1) - 2^(-a)*x*(-a+1) - 1)/(2^(-a+1)-2^(-a)*(-a+1) - 1) 72 | } 73 | res[x < 0] <- 0 74 | res[x > 1] <- 1 75 | 76 | res 77 | } 78 | 79 | mstpareto <- function(order, a) 80 | { 81 | if(order == 1) 82 | return(ifelse(a == 1, 2*log(2)-1, (2^(-a+1) - 2^(-a)*(-a+1)-1)/(-a+1)/(1-2^(-a)) )) 83 | else 84 | stop("not yet implemented") 85 | } 86 | 87 | -------------------------------------------------------------------------------- /man/1infl-unif.Rd: -------------------------------------------------------------------------------- 1 | \name{oiunif} 2 | \alias{oiunif} 3 | \alias{doiunif} 4 | \alias{poiunif} 5 | \alias{qoiunif} 6 | \alias{roiunif} 7 | \alias{ecoiunif} 8 | \alias{moiunif} 9 | \alias{tloiunif} 10 | 11 | \title{ 12 | One-inflated uniform distribution 13 | } 14 | \description{ 15 | These functions perform probabilistic analysis as well as random sampling 16 | on one-inflated uniform distribution. 17 | 18 | } 19 | \usage{ 20 | 21 | doiunif(x, p1, log=FALSE) 22 | poiunif(q, p1, lower.tail = TRUE, log.p = FALSE) 23 | qoiunif(p, p1, lower.tail = TRUE, log.p = FALSE) 24 | roiunif(n, p1) 25 | ecoiunif(x, p1) 26 | moiunif(order, p1) 27 | tloiunif(p1) 28 | 29 | } 30 | 31 | \arguments{ 32 | \item{x, q}{ 33 | vector of quantiles. 34 | } 35 | \item{p}{ 36 | vector of probabilities. 37 | } 38 | \item{n}{ 39 | number of observations. If \code{length(n) > 1}, the length is take to be the number required. 40 | } 41 | \item{p1}{ 42 | parameter. 43 | } 44 | \item{order}{ 45 | order of the raw moment. 46 | } 47 | \item{log, log.p}{ 48 | logical; if \code{TRUE}, probabilities \code{p} are given as log(p). 49 | } 50 | \item{lower.tail}{ 51 | logical; if \code{TRUE} (default), probabilities are \eqn{P[X <= x]}, otherwise, \eqn{P[X> x]}. 52 | } 53 | 54 | } 55 | \details{ 56 | \code{d,p,q,ec,m,tl}-\code{oiunif} functions computes the density function, 57 | the distribution function, the quantile function, the exposure curve function, 58 | raw moments and total loss of the one-inflated uniform distribution. 59 | \code{roiunif} generates random variates of this distribution. 60 | } 61 | \value{ 62 | A numeric value or a vector. 63 | } 64 | 65 | \author{ 66 | Dutang Christophe 67 | } 68 | \seealso{ 69 | \code{\link{mbbefd-distr}} and \code{\link{oidistribution}}. 70 | } 71 | \examples{ 72 | 73 | #density 74 | curve(doiunif(x, 1/3), n=200, ylim=0:1) 75 | 76 | #cdf 77 | curve(poiunif(x, 1/3), n=200) 78 | } 79 | \keyword{distribution} 80 | -------------------------------------------------------------------------------- /man/mbbefd-package.Rd: -------------------------------------------------------------------------------- 1 | \name{mbbefd-package} 2 | \alias{mbbefd-package} 3 | \docType{package} 4 | \title{ 5 | \packageTitle{mbbefd} 6 | } 7 | \description{ 8 | The idea of this package emerged in 2013 from G.A. Spedicato who 9 | at this time worked in the area of quantitative risk assessment. 10 | In 2015, M. Gesmann and C. Dutang joined the project. 11 | This project is hosted at \href{https://github.com/spedygiorgio/mbbefd}{github}. 12 | 13 | This package contains the core functions of the two parametrizations 14 | of the MBBEFD distribution 15 | (distribution function, density, quantile functions, random generation, 16 | aka d, p, q, r) 17 | as well as MBBEFD exposure curve (ec) and raw moments (m). 18 | 19 | This package also provides other distributions used for destruction rate 20 | modelling, that is the beta, the shifted truncated Pareto 21 | and the generalized beta distributions. 22 | Due to the presence of a total loss, a one-inflated version of the 23 | previous distributions is also provided. 24 | 25 | The vignette shows code snippets to fit the distribution to empirical data: \href{../doc/introduction_to_mbbefd.pdf}{Exposure rating, destruction rate models and the mbbefd package}. 26 | 27 | } 28 | 29 | \author{ 30 | 31 | Christophe Dutang (maintainer), Giorgio Spedicato, Markus Gesmann 32 | 33 | } 34 | \references{ 35 | BERNEGGER, STEFAN (1997). 36 | \emph{The Swiss Re Exposure Curves And The MBBEFD Distribution Class}, 37 | ASTIN Bulletin, 27(1), pp99-111, \doi{https://doi.org/10.2143/AST.27.1.563208}. 38 | } 39 | \keyword{ package } 40 | \seealso{ 41 | See \code{\link{mbbefd-distr}} for the MBBEFD distribution;\cr 42 | \code{\link{swissRe}}, \code{\link{exposureCurve}} for exposure curves;\cr 43 | \code{\link{gbeta}}, \code{\link{stpareto}} for finite-support distributions;\cr 44 | \code{\link{oidistribution}}, \code{\link{oibeta}}, \code{\link{oigbeta}}, \code{\link{oiunif}}, \code{\link{oistpareto}} for one-inflated distributions. 45 | } 46 | -------------------------------------------------------------------------------- /tests/test-mbbefd-1stparam-def-prog.R: -------------------------------------------------------------------------------- 1 | library(mbbefd) 2 | 3 | #test of MBBEFD(a,b) distribution 4 | n <- 1e5 5 | 6 | # length(b) > 1 7 | a <- 2 8 | b <- c(1/2:10, Inf) 9 | z <- 1/3 10 | cbind(ecmbbefd(z, a, b), log((a+b^z)/(a+1))/log((a+b)/(a+1))) 11 | cbind(pmbbefd(z, a, b), 1 - (a+1)*b^z/(a+b^z)) 12 | cbind(dmbbefd(z, a, b), -a * (a+1) * b^z * log(b) / (a + b^z)^2 ) 13 | cbind(qmbbefd(z, a, b), log((1-z)*a/(a+z))/log(b) ) 14 | cbind(tlmbbefd(a, b), (a+1)*b/(a+b)) 15 | 16 | #mbbefd:::rmbbefdR(3, a, b) 17 | #rmbbefd(3, a, b) 18 | 19 | # length(a) > 1 20 | a <- c(2:10, Inf) 21 | b <- 1/2 22 | z <- 1/3 23 | cbind(ecmbbefd(z, a, b), log((a+b^z)/(a+1))/log((a+b)/(a+1))) 24 | cbind(pmbbefd(z, a, b), 1 - (a+1)*b^z/(a+b^z)) 25 | cbind(dmbbefd(z, a, b), -a * (a+1) * b^z * log(b) / (a + b^z)^2 ) 26 | cbind(qmbbefd(z, a, b), log((1-z)*a/(a+z))/log(b) ) 27 | cbind(tlmbbefd(a, b), (a+1)*b/(a+b)) 28 | 29 | # length(x) > 1 30 | a <- 2 31 | b <- 1/2 32 | z <- seq(-1/2, 3/2, length=21) 33 | cbind(z, ecmbbefd(z, a, b), log((a+b^z)/(a+1))/log((a+b)/(a+1))) 34 | cbind(z, pmbbefd(z, a, b), 1 - (a+1)*b^z/(a+b^z)) 35 | cbind(z, dmbbefd(z, a, b), -a * (a+1) * b^z * log(b) / (a + b^z)^2 ) 36 | cbind(z, qmbbefd(z, a, b), log((1-z)*a/(a+z))/log(b) ) 37 | 38 | # length(a,b,x) > 1 39 | a <- 2:4 40 | b <- 1/2:5 41 | z <- 1/2:13 42 | a2 <- rep_len(a, length(z)) 43 | b2 <- rep_len(b, length(z)) 44 | cbind(ecmbbefd(z, a, b), log((a2+b2^z)/(a2+1))/log((a2+b2)/(a2+1))) 45 | cbind(pmbbefd(z, a, b), 1 - (a2+1)*b2^z/(a2+b2^z)) 46 | cbind(dmbbefd(z, a, b), -a2 * (a2+1) * b2^z * log(b2) / (a2 + b2^z)^2 ) 47 | cbind(qmbbefd(z, a, b), log((1-z)*a/(a+z))/log(b) ) 48 | 49 | # length(a,b,x) = 0 50 | a <- 2:4 51 | b <- numeric(0) 52 | z <- 1/2:10 53 | ecmbbefd(z, a, b) 54 | pmbbefd(z, a, b) 55 | dmbbefd(z, a, b) 56 | qmbbefd(z, a, b) 57 | 58 | # a, b, x character 59 | a <- "a" 60 | b <- 1/2 61 | z <- 1/2:10 62 | try(ecmbbefd(z, a, b)) 63 | try(pmbbefd(z, a, b)) 64 | try(dmbbefd(z, a, b)) 65 | 66 | 67 | -------------------------------------------------------------------------------- /R/distr-1infl-distrib.R: -------------------------------------------------------------------------------- 1 | #d, p, q, r function for one-inflated distribution 2 | 3 | 4 | doifun <- function(x, dfun, p1, log=FALSE, ...) 5 | { 6 | if(!(p1 >= 0 && p1 <= 1)) 7 | return(rep(NaN, length(x))) 8 | 9 | res <- rep(p1, length(x)) 10 | res[x != 1] <- dfun(x[x != 1], log=FALSE, ...)*(1 - p1) 11 | 12 | if(log) 13 | res <- log(res) 14 | res 15 | } 16 | 17 | poifun <- function(q, pfun, p1, lower.tail = TRUE, log.p = FALSE, ...) 18 | { 19 | if(!(p1 >= 0 && p1 <= 1)) 20 | return(rep(NaN, length(q))) 21 | 22 | res <- pfun(q, lower.tail = TRUE, log.p = FALSE, ...)*(1 - p1) + p1*(q >= 1) 23 | 24 | if(!lower.tail) 25 | res <- 1-res 26 | if(log.p) 27 | res <- log(res) 28 | 29 | res 30 | } 31 | 32 | 33 | qoifun <- function(p, qfun, p1, lower.tail = TRUE, log.p = FALSE, ...) 34 | { 35 | if(!(p1 >= 0 && p1 <= 1)) 36 | return(rep(NaN, length(p))) 37 | 38 | p <- p/(1-p1) #transformed quantile 39 | if(!lower.tail) 40 | p <- 1-p 41 | if(log.p) 42 | p <- exp(p) 43 | 44 | res <- qfun(p, lower.tail = TRUE, log.p = FALSE, ...) 45 | res[p >= 1-p1] <- 1 46 | 47 | res 48 | } 49 | 50 | roifun <- function(n, rfun, p1, ...) 51 | { 52 | n <- ifelse(length(n)>1, length(n), n) 53 | if(!(p1 >= 0 && p1 <= 1)) 54 | return(rep(NaN, n)) 55 | res <- rfun(n, ...) 56 | res[rbinom(n, 1, p1) == 1] <- 1 57 | res 58 | } 59 | 60 | #exposure curve and moment functions 61 | ecoifun <- function(x, ecfun, mfun, p1, ...) 62 | { 63 | if(!(p1 >= 0 && p1 <= 1)) 64 | return(rep(NaN, length(x))) 65 | 66 | G0 <- ecfun(x, ...) #exposure curve 67 | E0 <- mfun(order=1, ...) #expectation 68 | 69 | ((1-p1)*G0 + p1*x/E0)/(1-p1+p1/E0) 70 | } 71 | 72 | 73 | # moment function 74 | moifun <- function(order, mfun, p1, ...) 75 | { 76 | if(!(p1 >= 0 && p1 <= 1)) 77 | return(rep(NaN, length(order))) 78 | 79 | E0 <- mfun(order=order, ...) #expectation 80 | p1 + (1-p1)*E0 81 | } 82 | 83 | #total loss function 84 | tloifun <- function(p1, ...) 85 | { 86 | p1 87 | } 88 | -------------------------------------------------------------------------------- /man/1infl-stpareto.Rd: -------------------------------------------------------------------------------- 1 | \name{oistpareto} 2 | \alias{oistpareto} 3 | \alias{doistpareto} 4 | \alias{poistpareto} 5 | \alias{qoistpareto} 6 | \alias{roistpareto} 7 | \alias{ecoistpareto} 8 | \alias{moistpareto} 9 | \alias{tloistpareto} 10 | 11 | \title{ 12 | One-inflated shifted truncated pareto distribution 13 | } 14 | \description{ 15 | These functions perform probabilistic analysis as well as random sampling 16 | on one-inflated shifted truncated pareto distribution. 17 | 18 | } 19 | \usage{ 20 | 21 | doistpareto(x, a, p1, log=FALSE) 22 | poistpareto(q, a, p1, lower.tail = TRUE, log.p = FALSE) 23 | qoistpareto(p, a, p1, lower.tail = TRUE, log.p = FALSE) 24 | roistpareto(n, a, p1) 25 | ecoistpareto(x, a, p1) 26 | moistpareto(order, a, p1) 27 | tloistpareto(a, p1) 28 | 29 | } 30 | 31 | \arguments{ 32 | \item{x, q}{ 33 | vector of quantiles. 34 | } 35 | \item{p}{ 36 | vector of probabilities. 37 | } 38 | \item{n}{ 39 | number of observations. If \code{length(n) > 1}, the length is take to be the number required. 40 | } 41 | \item{a, p1}{ 42 | parameters. 43 | } 44 | \item{order}{ 45 | order of the raw moment. 46 | } 47 | \item{log, log.p}{ 48 | logical; if \code{TRUE}, probabilities \code{p} are given as log(p). 49 | } 50 | \item{lower.tail}{ 51 | logical; if \code{TRUE} (default), probabilities are \eqn{P[X <= x]}, otherwise, \eqn{P[X> x]}. 52 | } 53 | 54 | } 55 | \details{ 56 | \code{d,p,q,ec,m,tl}-\code{oistpareto} functions computes the density function, 57 | the distribution function, the quantile function, the exposure curve function, 58 | raw moments and total loss of the one-inflated shifted truncated pareto distribution. 59 | \code{roistpareto} generates random variates of this distribution. 60 | 61 | } 62 | \value{ 63 | A numeric value or a vector. 64 | } 65 | 66 | \author{ 67 | Dutang Christophe 68 | } 69 | \seealso{ 70 | \code{\link{mbbefd-distr}} and \code{\link{oidistribution}}. 71 | } 72 | \examples{ 73 | 74 | #density 75 | curve(doistpareto(x, 2, 1/3), n=200) 76 | 77 | #cdf 78 | curve(poistpareto(x, 2, 1/3), n=200) 79 | } 80 | \keyword{distribution} 81 | -------------------------------------------------------------------------------- /man/1infl-beta.Rd: -------------------------------------------------------------------------------- 1 | \name{oibeta} 2 | \alias{oibeta} 3 | \alias{doibeta} 4 | \alias{poibeta} 5 | \alias{qoibeta} 6 | \alias{roibeta} 7 | \alias{ecoibeta} 8 | \alias{moibeta} 9 | \alias{tloibeta} 10 | 11 | \title{ 12 | One-inflated beta distribution 13 | } 14 | \description{ 15 | These functions perform probabilistic analysis as well as random sampling 16 | on one-inflated beta distribution. 17 | 18 | } 19 | \usage{ 20 | 21 | doibeta(x, shape1, shape2, p1, ncp=0, log=FALSE) 22 | poibeta(q, shape1, shape2, p1, ncp=0, lower.tail = TRUE, log.p = FALSE) 23 | qoibeta(p, shape1, shape2, p1, ncp=0, lower.tail = TRUE, log.p = FALSE) 24 | roibeta(n, shape1, shape2, p1, ncp=0) 25 | ecoibeta(x, shape1, shape2, p1, ncp=0) 26 | moibeta(order, shape1, shape2, p1, ncp=0) 27 | tloibeta(shape1, shape2, p1, ncp=0) 28 | 29 | } 30 | 31 | \arguments{ 32 | \item{x, q}{ 33 | vector of quantiles. 34 | } 35 | \item{p}{ 36 | vector of probabilities. 37 | } 38 | \item{n}{ 39 | number of observations. If \code{length(n) > 1}, the length is take to be the number required. 40 | } 41 | \item{p1, shape1, shape2, ncp}{ 42 | parameters. 43 | } 44 | \item{order}{ 45 | order of the raw moment. 46 | } 47 | \item{log, log.p}{ 48 | logical; if \code{TRUE}, probabilities \code{p} are given as log(p). 49 | } 50 | \item{lower.tail}{ 51 | logical; if \code{TRUE} (default), probabilities are \eqn{P[X <= x]}, otherwise, \eqn{P[X> x]}. 52 | } 53 | 54 | } 55 | \details{ 56 | \code{d,p,q,ec,m,tl}-\code{oibeta} functions computes the density function, 57 | the distribution function, the quantile function, the exposure curve function, 58 | raw moments and total loss of the one-inflated beta distribution. 59 | \code{roibeta} generates random variates of this distribution. 60 | 61 | } 62 | \value{ 63 | A numeric value or a vector. 64 | } 65 | 66 | \author{ 67 | Dutang Christophe 68 | } 69 | \seealso{ 70 | \code{\link{mbbefd-distr}} and \code{\link{oidistribution}}. 71 | } 72 | \examples{ 73 | 74 | #density 75 | curve(doibeta(x, 3, 2, 1/3), n=200) 76 | 77 | #cdf 78 | curve(poibeta(x, 3, 2, 1/3), n=200) 79 | } 80 | \keyword{distribution} 81 | -------------------------------------------------------------------------------- /man/1infl-genbeta.Rd: -------------------------------------------------------------------------------- 1 | \name{oigbeta} 2 | \alias{oigbeta} 3 | \alias{doigbeta} 4 | \alias{poigbeta} 5 | \alias{qoigbeta} 6 | \alias{roigbeta} 7 | \alias{ecoigbeta} 8 | \alias{moigbeta} 9 | \alias{tloigbeta} 10 | 11 | \title{ 12 | One-inflated generalized beta of the first kind (GB1)) distribution 13 | } 14 | \description{ 15 | These functions perform probabilistic analysis as well as random sampling 16 | on one-inflated GB1 distribution. 17 | 18 | } 19 | \usage{ 20 | 21 | doigbeta(x, shape0, shape1, shape2, p1, log=FALSE) 22 | poigbeta(q, shape0, shape1, shape2, p1, lower.tail = TRUE, log.p = FALSE) 23 | qoigbeta(p, shape0, shape1, shape2, p1, lower.tail = TRUE, log.p = FALSE) 24 | roigbeta(n, shape0, shape1, shape2, p1) 25 | ecoigbeta(x, shape0, shape1, shape2, p1) 26 | moigbeta(order, shape0, shape1, shape2, p1) 27 | tloigbeta(shape0, shape1, shape2, p1) 28 | 29 | } 30 | 31 | \arguments{ 32 | \item{x, q}{ 33 | vector of quantiles. 34 | } 35 | \item{p}{ 36 | vector of probabilities. 37 | } 38 | \item{n}{ 39 | number of observations. If \code{length(n) > 1}, the length is take to be the number required. 40 | } 41 | \item{p1, shape0, shape1, shape2}{ 42 | shape parameters. 43 | } 44 | \item{order}{ 45 | order of the raw moment. 46 | } 47 | \item{log, log.p}{ 48 | logical; if \code{TRUE}, probabilities \code{p} are given as log(p). 49 | } 50 | \item{lower.tail}{ 51 | logical; if \code{TRUE} (default), probabilities are \eqn{P[X <= x]}, otherwise, \eqn{P[X> x]}. 52 | } 53 | 54 | } 55 | \details{ 56 | \code{d,p,q,ec,m,tl}-\code{oigbeta} functions computes the density function, 57 | the distribution function, the quantile function, the exposure curve function, 58 | raw moments and total loss of the one-inflated GB1 distribution. 59 | \code{roigbeta} generates random variates of this distribution. 60 | 61 | } 62 | \value{ 63 | A numeric value or a vector. 64 | } 65 | 66 | \author{ 67 | Dutang Christophe 68 | } 69 | \seealso{ 70 | \code{\link{mbbefd-distr}} and \code{\link{oidistribution}}. 71 | } 72 | \examples{ 73 | 74 | #density 75 | curve(doigbeta(x, 3, 2, 3, 1/3), n=200) 76 | 77 | #cdf 78 | curve(poigbeta(x, 3, 2, 3, 1/3), n=200) 79 | } 80 | \keyword{distribution} 81 | -------------------------------------------------------------------------------- /src/RcppExports.cpp: -------------------------------------------------------------------------------- 1 | // Generated by using Rcpp::compileAttributes() -> do not edit by hand 2 | // Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 3 | 4 | #include 5 | 6 | using namespace Rcpp; 7 | 8 | #ifdef RCPP_USE_GLOBAL_ROSTREAM 9 | Rcpp::Rostream& Rcpp::Rcout = Rcpp::Rcpp_cout_get(); 10 | Rcpp::Rostream& Rcpp::Rcerr = Rcpp::Rcpp_cerr_get(); 11 | #endif 12 | 13 | // g2a 14 | double g2a(double g, double b); 15 | RcppExport SEXP _mbbefd_g2a(SEXP gSEXP, SEXP bSEXP) { 16 | BEGIN_RCPP 17 | Rcpp::RObject rcpp_result_gen; 18 | Rcpp::RNGScope rcpp_rngScope_gen; 19 | Rcpp::traits::input_parameter< double >::type g(gSEXP); 20 | Rcpp::traits::input_parameter< double >::type b(bSEXP); 21 | rcpp_result_gen = Rcpp::wrap(g2a(g, b)); 22 | return rcpp_result_gen; 23 | END_RCPP 24 | } 25 | // rmbbefdC 26 | NumericVector rmbbefdC(int n, double a, double b); 27 | RcppExport SEXP _mbbefd_rmbbefdC(SEXP nSEXP, SEXP aSEXP, SEXP bSEXP) { 28 | BEGIN_RCPP 29 | Rcpp::RObject rcpp_result_gen; 30 | Rcpp::RNGScope rcpp_rngScope_gen; 31 | Rcpp::traits::input_parameter< int >::type n(nSEXP); 32 | Rcpp::traits::input_parameter< double >::type a(aSEXP); 33 | Rcpp::traits::input_parameter< double >::type b(bSEXP); 34 | rcpp_result_gen = Rcpp::wrap(rmbbefdC(n, a, b)); 35 | return rcpp_result_gen; 36 | END_RCPP 37 | } 38 | // rMBBEFDC 39 | NumericVector rMBBEFDC(int n, double g, double b); 40 | RcppExport SEXP _mbbefd_rMBBEFDC(SEXP nSEXP, SEXP gSEXP, SEXP bSEXP) { 41 | BEGIN_RCPP 42 | Rcpp::RObject rcpp_result_gen; 43 | Rcpp::RNGScope rcpp_rngScope_gen; 44 | Rcpp::traits::input_parameter< int >::type n(nSEXP); 45 | Rcpp::traits::input_parameter< double >::type g(gSEXP); 46 | Rcpp::traits::input_parameter< double >::type b(bSEXP); 47 | rcpp_result_gen = Rcpp::wrap(rMBBEFDC(n, g, b)); 48 | return rcpp_result_gen; 49 | END_RCPP 50 | } 51 | 52 | static const R_CallMethodDef CallEntries[] = { 53 | {"_mbbefd_g2a", (DL_FUNC) &_mbbefd_g2a, 2}, 54 | {"_mbbefd_rmbbefdC", (DL_FUNC) &_mbbefd_rmbbefdC, 3}, 55 | {"_mbbefd_rMBBEFDC", (DL_FUNC) &_mbbefd_rMBBEFDC, 3}, 56 | {NULL, NULL, 0} 57 | }; 58 | 59 | RcppExport void R_init_mbbefd(DllInfo *dll) { 60 | R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); 61 | R_useDynamicSymbols(dll, FALSE); 62 | } 63 | -------------------------------------------------------------------------------- /R/util-constr-mbbefd.R: -------------------------------------------------------------------------------- 1 | 2 | #to meet the standard 'fn' argument and specific name arguments, 3 | 4 | #constraint function for MBBEFD(a,b) 5 | constrmbbefd <- function(x, fix.arg, obs, ddistnam) 6 | { 7 | res <- x[1]*(1-x[2]) #a*(1-b) >= 0 8 | names(res) <- NULL 9 | res 10 | } 11 | #domain : (a,b) in (-1, 0) x (1, +Inf) 12 | constrmbbefd1 <- function(x, fix.arg, obs, ddistnam) 13 | { 14 | res <- c(x[1]+1, -x[1], x[2]-1, x[1]*(1-x[2])) #-1 < a < 0, b > 1, a*(1-b) >= 0 15 | names(res) <- NULL 16 | res 17 | } 18 | constrmbbefd1jac <- function(x, fix.arg, obs, ddistnam) 19 | { 20 | j <- matrix(0, 4, 2) 21 | j[1,] <- c(1, 0) 22 | j[2,] <- c(0, -1) 23 | j[3,] <- c(1, 0) 24 | j[4,] <- c(-x[2], -x[1]) 25 | dimnames(j) <- NULL 26 | j 27 | } 28 | 29 | #domain : (a,b) in (0, +Inf) x (0, 1) 30 | constrmbbefd2 <- function(x, fix.arg, obs, ddistnam) 31 | { 32 | res <- c(x[1], x[1], 1-x[2], x[1]*(1-x[2])) #0 < a , 0 < b < 1, a*(1-b) >= 0 33 | names(res) <- NULL 34 | res 35 | } 36 | constrmbbefd2jac <- function(x, fix.arg, obs, ddistnam) 37 | { 38 | j <- matrix(0, 4, 2) 39 | j[1,] <- c(1, 0) 40 | j[2,] <- c(0, 1) 41 | j[3,] <- c(0, -1) 42 | j[4,] <- c(-x[2], -x[1]) 43 | dimnames(j) <- NULL 44 | j 45 | } 46 | 47 | 48 | #constraint function for MBBEFD(g,b) 49 | constrMBBEFD <- function(x, fix.arg, obs, ddistnam) 50 | { 51 | res <- c(x[1]-1, x[2]) #g >= 1, b > 0 52 | names(res) <- NULL 53 | res 54 | } 55 | #domain : (g,b) in (1, +Inf) x (1, +Inf) with gb > 1 56 | constrMBBEFD1 <- function(x, fix.arg, obs, ddistnam) 57 | { 58 | res <- c(x[1]-1, x[2]-1, x[1]*x[2]-1) #g > 1, b > 1, gb > 1 59 | names(res) <- NULL 60 | res 61 | } 62 | constrMBBEFD1jac <- function(x, fix.arg, obs, ddistnam) 63 | { 64 | j <- matrix(0, 3, 2) 65 | j[1,] <- c(1, 0) 66 | j[2,] <- c(0, 1) 67 | j[3,] <- c(x[2], x[1]) 68 | dimnames(j) <- NULL 69 | j 70 | } 71 | 72 | #domain : (g,b) in (1, +Inf) x (0, 1) with gb < 1 73 | constrMBBEFD2 <- function(x, fix.arg, obs, ddistnam) 74 | { 75 | res <- c(x[1]-1, 1-x[2], x[2], 1-x[1]*x[2]) #g > 1, 1 > b > 0, gb < 1 76 | names(res) <- NULL 77 | res 78 | } 79 | constrMBBEFD2jac <- function(x, fix.arg, obs, ddistnam) 80 | { 81 | j <- matrix(0, 4, 2) 82 | j[1,] <- c(1, 0) 83 | j[2,] <- c(0, -1) 84 | j[3,] <- c(0, 1) 85 | j[4,] <- c(-x[2], -x[1]) 86 | dimnames(j) <- NULL 87 | j 88 | } 89 | 90 | -------------------------------------------------------------------------------- /man/1infl-Distribution.Rd: -------------------------------------------------------------------------------- 1 | \name{oidistribution} 2 | \alias{oidistribution} 3 | \alias{doifun} 4 | \alias{poifun} 5 | \alias{qoifun} 6 | \alias{roifun} 7 | \alias{ecoifun} 8 | \alias{moifun} 9 | \alias{tloifun} 10 | 11 | \title{ 12 | One-inflated distributions 13 | } 14 | \description{ 15 | These functions perform probabilistic analysis as well as random sampling 16 | on one-inflated distributions. 17 | 18 | } 19 | \usage{ 20 | 21 | doifun(x, dfun, p1, log=FALSE, ...) 22 | poifun(q, pfun, p1, lower.tail = TRUE, log.p = FALSE, ...) 23 | qoifun(p, qfun, p1, lower.tail = TRUE, log.p = FALSE, ...) 24 | roifun(n, rfun, p1, ...) 25 | ecoifun(x, ecfun, mfun, p1, ...) 26 | moifun(order, mfun, p1, ...) 27 | tloifun(p1, ...) 28 | 29 | } 30 | 31 | \arguments{ 32 | \item{x, q}{ 33 | vector of quantiles. 34 | } 35 | \item{p}{ 36 | vector of probabilities. 37 | } 38 | \item{n}{ 39 | number of observations. If \code{length(n) > 1}, the length is take to be the number required. 40 | } 41 | \item{dfun, pfun, qfun, rfun}{ 42 | d, p, q, r functions of the original distribution. 43 | } 44 | \item{p1}{ 45 | parameter for the probability at \code{x=1}. 46 | } 47 | \item{ecfun, mfun}{ 48 | exposure curve and moment functions which should have arguments 49 | \code{x, ...} and \code{order, ...} respectively. 50 | } 51 | \item{order}{ 52 | order of the raw moment. 53 | } 54 | \item{log, log.p}{ 55 | logical; if \code{TRUE}, probabilities \code{p} are given as log(p). 56 | } 57 | \item{lower.tail}{ 58 | logical; if \code{TRUE} (default), probabilities are \eqn{P[X <= x]}, otherwise, \eqn{P[X> x]}. 59 | } 60 | \item{\dots}{ 61 | further arguments to pass to \code{dfun, pfun, qfun, rfun, ecfun, mfun}. 62 | } 63 | 64 | } 65 | \details{ 66 | \code{d,p,q,ec,m,tl} functions of \code{oifun} computes the density function, 67 | the distribution function, the quantile function, the exposure curve function, 68 | raw moments and total loss of an one-inflated distribution of an original distribution 69 | specified by \code{d,p,q,ec,m}-\code{fun}. 70 | \code{roifun} generates random variates of the resulting distribution. 71 | 72 | } 73 | \value{ 74 | A numeric value or a vector. 75 | } 76 | 77 | \author{ 78 | Dutang Christophe 79 | } 80 | \seealso{ 81 | \code{\link{oibeta}}, \code{\link{oiunif}}, \code{\link{oistpareto}} and \code{\link{oidistribution}}. 82 | } 83 | 84 | \keyword{distribution} 85 | -------------------------------------------------------------------------------- /vignettes/test-beta.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Some check of beta distribution" 3 | author: "C. Dutang and G.A. Spedicato" 4 | date: "18/04/2018" 5 | output: 6 | bookdown::html_document2: 7 | base_format: rmarkdown::html_vignette 8 | fig_caption: yes 9 | toc: true 10 | number_sections: yes 11 | vignette: | 12 | %\VignetteIndexEntry{test-beta} 13 | %\VignetteEngine{knitr::rmarkdown} 14 | %!\VignetteEncoding{UTF-8} 15 | \usepackage[utf8]{inputenc} 16 | --- 17 | 18 | ```{r setup, include=FALSE} 19 | knitr::opts_chunk$set(echo = TRUE) 20 | ``` 21 | 22 | # Formula for beta(a,b) 23 | 24 | From loss models with their notation (which differs from the NIST 25 | handbook of mathematical functions), we have 26 | $$ 27 | E(X) = \frac{\Gamma(a+b)\Gamma(a+1)}{\Gamma(a)\Gamma(a+b+1)} 28 | = \frac{a}{a+b} 29 | $$ 30 | and 31 | $$ 32 | E(\min(X,d)) = \frac{a}{a+b}\beta(a+1,b;x) + x(1-\beta(a,b;x)) 33 | $$ 34 | where $\beta(.,.;.)$ denotes the incomplete beta function 35 | $$ 36 | \beta(a,b;x)= \frac{\Gamma(a)\Gamma(b)}{\Gamma(a+b)} \int_0^x t^{a-1}(1-t)^{b-1}dt 37 | = \frac{\int_0^x t^{a-1}(1-t)^{b-1}dt}{\beta(a,b)}. 38 | $$ 39 | Using (8.17.20) of NIST and recurrence relation of the beta function, 40 | $$ 41 | \beta(a+1,b;x) = \beta(a,b;x) - \frac{x^a(1-x)^b}{a\beta(a,b)} 42 | $$ 43 | Therefore the exposure curve is 44 | \begin{eqnarray*} 45 | G(x) 46 | &=& \frac{E(\min(X,x))}{E(X)} 47 | = \left(\frac{a}{a+b}\beta(a+1,b;x) + x(1-\beta(a,b;x)) \right)\frac{a+b}{a} 48 | = \beta(a+1,b;x) + x(1-\beta(a,b;x)) \frac{a+b}{a} 49 | \\ 50 | &=& 51 | \beta(a,b;x) - \frac{x^a(1-x)^b}{a\beta(a,b)} + x(1-\beta(a,b;x)) \frac{a+b}{a} 52 | \end{eqnarray*} 53 | 54 | # Check by Monte-Carlo 55 | 56 | Intermediate result: Equation (8.17.20) of NIST 57 | ```{r} 58 | deltabetaincomp <- function(a,b,d) 59 | -d^a*(1-d)^b/a/beta(a,b) 60 | deltatheo <- function(a,b,d) 61 | pbeta(d,a+1,b)-pbeta(d,a,b) 62 | c(deltabetaincomp(pi, 1/pi, 4/5), deltatheo(pi, 1/pi, 4/5)) 63 | ``` 64 | 65 | 66 | Theoretical value 67 | ```{r, message=FALSE} 68 | library(mbbefd) 69 | theo <- function(a,b,d) 70 | d*(1 - pbeta(d,a,b))*{a+b}/{a}+pbeta(d,a,b)-{d^a*(1-d)^b}/{a*beta(a,b)} 71 | 72 | theo2 <- function(a,b,d) 73 | pbeta(d,a+1,b) + d*(1-pbeta(d,a,b))*(a+b)/a 74 | emp <- function(n, a, b, d) 75 | { 76 | x <- rbeta(n, a, b) 77 | mean(pmin(x,d))/mean(x) 78 | } 79 | c(theo(3,2,1/pi), theo2(3,2,1/pi), emp(1e6, 3,2,1/pi), ecbeta(1/pi, 3, 2)) 80 | ``` 81 | 82 | 83 | 84 | -------------------------------------------------------------------------------- /man/lossalae.Rd: -------------------------------------------------------------------------------- 1 | \name{lossalae} 2 | \alias{lossalaefull} 3 | \title{General Liability Claims} 4 | \usage{ 5 | data(lossalaefull) 6 | 7 | } 8 | \description{ 9 | The \code{lossalae} is a data frame of 1500 rows and 4 columns 10 | containing 1,500 general liability claims randomly chosen from 11 | late settlement lags and were provided by Insurance Services Office, Inc. 12 | Each claim consists of an indemnity payment (the loss, X1) and 13 | an allocated loss adjustment expense (ALAE). ALAE are types of 14 | insurance company expenses that are specifically attributable 15 | to the settlement of individual claims such as lawyers' fees 16 | and claims investigation expenses. 17 | The third column is the underwriting limit of the policy and 18 | and the fourth column indicates a censored observation. 19 | 20 | 21 | } 22 | \format{ 23 | \code{lossalaefull} contains four columns: 24 | \describe{ 25 | \item{\code{Loss}}{A numeric vector containing the indemnity 26 | payments (USD).} 27 | \item{\code{ALAE}}{A numeric vector containing the allocated 28 | loss adjustment expenses (USD).} 29 | \item{\code{Limit}}{A numeric vector containing the policy 30 | limit (USD).} 31 | \item{\code{Censored}}{A binary indicating that the payments 32 | are capped to their policy limit (USD).} 33 | } 34 | } 35 | \source{ 36 | 37 | Frees, E. W. and Valdez, E. A. (1998) 38 | Understanding relationships using copulas. 39 | \emph{North American Actuarial Journal}, \bold{2}, 1--15, 40 | \doi{10.1080/10920277.1998.10595749}. 41 | 42 | } 43 | \references{ 44 | Klugman, S. A. and Parsa, R. (1999) 45 | Fitting bivariate loss distributions with copulas. 46 | \emph{Insurance: Mathematics and Economics}, \bold{24}, 139--148, 47 | \doi{10.1016/S0167-6687(98)00039-0}. 48 | 49 | Beirlant, J., Goegebeur, Y., Segers, J. and Teugels, J. L. (2004) 50 | \emph{Statistics of Extremes: Theory and Applications.}, 51 | Chichester, England: John Wiley and Sons, 52 | \doi{10.1002/0470012382}. 53 | 54 | Cebrian, A.C., Denuit, M. and Lambert, P. (2003). 55 | \emph{Analysis of bivariate tail dependence using extreme 56 | value copulas: An application to the SOA medical large claims 57 | database}, Belgian Actuarial Bulletin, Vol. 3, No. 1, 58 | \url{https://dial.uclouvain.be/pr/boreal/object/boreal:17222}. 59 | 60 | } 61 | 62 | \examples{ 63 | 64 | # (1) load of data 65 | # 66 | data(lossalaefull) 67 | 68 | } 69 | 70 | \keyword{datasets} 71 | -------------------------------------------------------------------------------- /man/eecf.Rd: -------------------------------------------------------------------------------- 1 | \name{eecf} 2 | \alias{eecf} 3 | \alias{plot.eecf} 4 | \alias{lines.eecf} 5 | \alias{print.eecf} 6 | \alias{summary.eecf} 7 | 8 | \title{ 9 | Empirical Exposure Curve Function 10 | } 11 | \description{ 12 | Compute an empirical exposure curve function, with 13 | several methods for plotting, printing, computing with 14 | such an object. 15 | 16 | } 17 | \usage{ 18 | 19 | eecf(x) 20 | 21 | 22 | \method{plot}{eecf}(x, \dots, ylab="Gn(x)", do.points=TRUE, 23 | col.01line = "gray70", pch = 19, main=NULL, ylim=NULL, 24 | add=FALSE) 25 | 26 | \method{lines}{eecf}(x, \dots) 27 | 28 | \method{print}{eecf}(x, digits= getOption("digits") - 2, \dots) 29 | 30 | \method{summary}{eecf}(object, \dots) 31 | } 32 | 33 | \arguments{ 34 | \item{x, object}{numeric vector of the observations for \code{eecf}; 35 | for the methods, an object of class \code{"eecf"}. 36 | } 37 | \item{\dots}{arguments to be passed to subsequent methods, e.g., 38 | to the \code{plot} method.} 39 | \item{ylab}{label for the y-axis.} 40 | \item{do.points}{logical; if \code{TRUE}, also draw points at 41 | the (\code{xlim} restricted) knot locations.} 42 | \item{col.01line}{numeric or character specifying the color of the 43 | horizontal lines at y = 0 and 1, see \code{\link{colors}}.} 44 | \item{pch}{plotting character.} 45 | \item{main}{main title.} 46 | \item{ylim}{the y limits of the plot.} 47 | \item{add}{logical; if \code{TRUE} add to an already existing plot.} 48 | \item{digits}{number of significant digits to use, see 49 | \code{\link{print}}.} 50 | 51 | } 52 | \details{ 53 | Compute a continuous empirical exposure curve and returns an object 54 | of class \code{"eecf"} similar to what an object returned 55 | by \code{\link{ecdf}}. 56 | 57 | } 58 | \value{ 59 | For \code{eecf}, a function of class \code{"eecf"}, inheriting 60 | from the \code{"function"} class. 61 | 62 | For the \code{summary} method, a summary of the knots of object 63 | with a \code{"header"} attribute. 64 | } 65 | 66 | \author{ 67 | Dutang Christophe 68 | } 69 | \seealso{ 70 | \code{\link{exposureCurve}}, \code{\link{ecdf}}. 71 | } 72 | \examples{ 73 | 74 | x <- c(0.4756816, 0.1594636, 0.1913558, 0.2387725, 0.1135414, 0.7775612, 75 | 0.6858736, 0.4340655, 0.3181558, 0.1134244) 76 | 77 | #print 78 | eecf(x) 79 | 80 | #summary 81 | summary(eecf(x)) 82 | 83 | #plot 84 | plot(eecf(x)) 85 | 86 | #lines 87 | lines(eecf(x[1:4]), col="red") 88 | } 89 | 90 | -------------------------------------------------------------------------------- /R/fitDR-output.R: -------------------------------------------------------------------------------- 1 | fitDR.addcomp <- function(x, theta, hessian=NULL, dist, method, convergence=0, vcov=NULL) 2 | { 3 | #components will be 4 | #"estimate", "method", "sd", "cor", "vcov", "loglik", "aic", "bic", "n", "data", 5 | #"distname", "fix.arg", "fix.arg.fun", "dots", "convergence", "discrete", "weights" 6 | 7 | f1 <- list(estimate=theta, weights=NULL, dots=NULL, fix.arg=NULL, fix.arg.fun=NULL, dots=NULL) 8 | #other fitdist components 9 | f1$convergence <- convergence 10 | f1$method <- method 11 | f1$n <- length(x) 12 | f1$data <- x 13 | f1$distname <- dist 14 | f1$discrete <- FALSE 15 | npar <- length(theta) 16 | 17 | #gof statistics 18 | if(any(is.na(theta))) 19 | { 20 | f1$loglik <- f1$aic <- f1$bic <- NA 21 | }else 22 | { 23 | f1$loglik <- LLfunc(obs=x, theta=theta, dist=dist) 24 | f1$aic <- -2*f1$loglik+2*npar 25 | f1$bic <- -2*f1$loglik+log(f1$n)*npar 26 | } 27 | 28 | #one-inflated uniform distribution 29 | if(dist %in% "oiunif") 30 | { 31 | stop("do not need to call fitDR.addcomp()") 32 | }else if(dist %in% c("oibeta", "oistpareto", "oigbeta")) 33 | { #one-inflated distribution with at least two parameters 34 | 35 | if(method == "mle") 36 | { 37 | p1 <- f1$estimate["p1"] 38 | if(is.null(hessian)) 39 | f1$vcov <- f1$sd <- f1$cor <- NULL 40 | else if(all(!is.na(hessian)) && qr(hessian)$rank == NCOL(hessian)) 41 | { 42 | subvcov <- solve(hessian) 43 | f1$vcov <- rbind(cbind(as.matrix(subvcov), rep(0, npar-1)), 44 | c(rep(0, npar-1), p1*(1-p1))) 45 | f1$vcov <- f1$vcov/f1$n 46 | dimnames(f1$vcov) <- list(names(f1$estimate), names(f1$estimate)) 47 | f1$sd <- sqrt(diag(f1$vcov)) 48 | f1$cor <- cov2cor(f1$vcov) 49 | }else 50 | { 51 | f1$vcov <- f1$sd <- f1$cor <- NULL 52 | } 53 | }else 54 | { 55 | f1$vcov <- f1$sd <- f1$cor <- NULL 56 | } 57 | }else 58 | { 59 | #non one-inflated distributions: mbbefd / MBBEFD 60 | if(method == "mle") 61 | { 62 | if(is.null(hessian)) 63 | f1$vcov <- f1$sd <- f1$cor <- NULL 64 | else if(all(!is.na(hessian)) && qr(hessian)$rank == NCOL(hessian)) 65 | { 66 | f1$vcov <- solve(hessian) 67 | f1$vcov <- f1$vcov/f1$n 68 | dimnames(f1$vcov) <- list(names(f1$estimate), names(f1$estimate)) 69 | f1$sd <- sqrt(diag(f1$vcov)) 70 | f1$cor <- cov2cor(f1$vcov) 71 | }else 72 | { 73 | f1$vcov <- f1$sd <- f1$cor <- NULL 74 | } 75 | }else 76 | { 77 | f1$vcov <- f1$sd <- f1$cor <- NULL 78 | } 79 | 80 | } 81 | #output 82 | f1 83 | } -------------------------------------------------------------------------------- /R/util-loglikfunc.R: -------------------------------------------------------------------------------- 1 | 2 | #log-likelihood function 3 | LLfunc <- function(obs, theta, dist) 4 | { 5 | dist <- match.arg(dist, c("oiunif", "oistpareto", "oibeta", "oigbeta", "mbbefd", "MBBEFD", "unif", "stpareto", "beta", "gbeta")) 6 | ddist <- paste0("d", dist) 7 | sum(log(do.call(ddist, c(list(obs), as.list(theta)) ) ) ) 8 | } 9 | 10 | 11 | #gradient of the log-likelihood function : only valid for parameter domain D1, D2 12 | grLLfunc <- function(obs, theta, dist) 13 | { 14 | dist <- match.arg(dist, c("mbbefd", "MBBEFD")) 15 | if(dist == "mbbefd") 16 | { 17 | g1 <- function(x, theta) 18 | { 19 | a <- theta[1]; b <- theta[2] 20 | ifelse(x == 1, (b-1)/(a+1)/(a+b), (2*a+1)/(a*(a+1)) - 2/(a+b^x)) 21 | } 22 | g2 <- function(x, theta) 23 | { 24 | a <- theta[1]; b <- theta[2] 25 | ifelse(x == 1, a/(b*(a+b)), x/b+1/(b*log(b))-2*b^x*x/(b*(a+b^x))) 26 | } 27 | c(sum(sapply(obs, g1, theta=theta)), sum(sapply(obs, g2, theta=theta))) 28 | }else 29 | { 30 | g1 <- function(x, theta) 31 | { 32 | g <- theta[1]; b <- theta[2] 33 | 34 | if(x != 1) 35 | { 36 | denom1 <- (g-1)*b^(1-x)+1-g*b 37 | res <- 1/(g-1) -2*(b^(1-x) - b)/denom1 38 | }else 39 | { 40 | res <- -1/g 41 | } 42 | res 43 | } 44 | g2 <- function(x, theta) 45 | { 46 | g <- theta[1]; b <- theta[2] 47 | 48 | if(x != 1) 49 | { 50 | denom1 <- (g-1)*b^(1-x)+1-g*b 51 | num1 <- 1/(b-1)+1/(b*log(b))+(1-x)/b 52 | num2 <- ((g-1)*(1-x)*b^(-x) - g)/denom1 53 | res <- num1+num2 54 | }else 55 | { 56 | res <- 0 57 | } 58 | res 59 | } 60 | c(sum(sapply(obs, g1, theta=theta)), sum(sapply(obs, g2, theta=theta))) 61 | } 62 | } 63 | 64 | #Hessian of the log-likelihood function 65 | heLLfunc <- function(obs, theta, dist) 66 | { 67 | dist <- match.arg(dist, c("mbbefd", "MBBEFD")) 68 | if(dist == "mbbefd") 69 | { 70 | h11 <- function(x, theta) 71 | { 72 | a <- theta[1]; b <- theta[2] 73 | ifelse(x == 1, 1/(a+b)^2-1/(a+1)^2, 2/(a+b^x)^2-1/a^2-1/(a+1)^2) 74 | } 75 | h21 <- function(x, theta) 76 | { 77 | a <- theta[1]; b <- theta[2] 78 | ifelse(x == 1, 1/(a+b)^2, 2*x*b^(x-1)/(a+b^x)^2) 79 | } 80 | h22 <- function(x, theta) 81 | { 82 | a <- theta[1]; b <- theta[2] 83 | ifelse(x == 1, 1/(a+b)^2-1/b^2, 84 | x/b^2-(log(b)+1)/(b^2*log(b)^2)-2*a*x/(b^2*(a+b^x))-2*a*x^2*b^x/(b^2*(a+b^x)^2)) 85 | } 86 | rbind(c(sum(sapply(obs, h11, theta=theta)), sum(sapply(obs, h21, theta=theta))), 87 | c(sum(sapply(obs, h21, theta=theta)), sum(sapply(obs, h22, theta=theta)))) 88 | }else 89 | { 90 | stop("not yet implemented.") 91 | } 92 | } 93 | -------------------------------------------------------------------------------- /man/distr-genbeta.Rd: -------------------------------------------------------------------------------- 1 | \name{gbeta} 2 | \alias{gbeta} 3 | \alias{dgbeta} 4 | \alias{pgbeta} 5 | \alias{qgbeta} 6 | \alias{rgbeta} 7 | \alias{ecgbeta} 8 | \alias{mgbeta} 9 | 10 | \alias{dgbeta1} 11 | 12 | 13 | \title{The generalized Beta of the first kind Distribution} 14 | \description{ 15 | Density, distribution function, quantile function and random 16 | generation for the GB1 distribution with parameters \code{shape0}, 17 | \code{shape1} and \code{shape2}. 18 | } 19 | \usage{ 20 | dgbeta(x, shape0, shape1, shape2, log = FALSE) 21 | pgbeta(q, shape0, shape1, shape2, lower.tail = TRUE, log.p = FALSE) 22 | qgbeta(p, shape0, shape1, shape2, lower.tail = TRUE, log.p = FALSE) 23 | rgbeta(n, shape0, shape1, shape2) 24 | ecgbeta(x, shape0, shape1, shape2) 25 | mgbeta(order, shape0, shape1, shape2) 26 | } 27 | \arguments{ 28 | \item{x, q}{vector of quantiles.} 29 | \item{p}{vector of probabilities.} 30 | \item{n}{number of observations. If \code{length(n) > 1}, the length 31 | is taken to be the number required.} 32 | \item{shape0, shape1, shape2}{positive parameters of the GB1 distribution.} 33 | \item{log, log.p}{logical; if TRUE, probabilities p are given as log(p).} 34 | \item{lower.tail}{logical; if TRUE (default), probabilities are 35 | \eqn{P[X \le x]}, otherwise, \eqn{P[X > x]}.} 36 | \item{order}{ 37 | order of the raw moment. 38 | } 39 | 40 | } 41 | \details{ 42 | The GB1 distribution with parameters \code{shape0} \eqn{= g}, 43 | \code{shape1} \eqn{= a} and \code{shape2} \eqn{= b} has density 44 | \deqn{f(x)=\frac{\Gamma(a+b)}{\Gamma(a)\Gamma(b)}{x}^{a/g-1} {(1-x^{1/g})}^{b-1}/g% 45 | }{\Gamma(a+b)/(\Gamma(a)\Gamma(b))x^(a/g-1)(1-x^{1/g})^(b-1)/g} 46 | for \eqn{a,b,g > 0} and \eqn{0 \le x \le 1} 47 | where the boundary values at \eqn{x=0} or \eqn{x=1} are defined as 48 | by continuity (as limits). 49 | 50 | } 51 | \value{ 52 | \code{dgbeta} gives the density, \code{pgbeta} the distribution 53 | function, \code{qgbeta} the quantile function, and \code{rgbeta} 54 | generates random deviates. 55 | 56 | } 57 | 58 | \references{ 59 | Becker, R. A., Chambers, J. M. and Wilks, A. R. (1988) 60 | \emph{The New S Language}, Wadsworth & Brooks/Cole, 61 | \doi{10.1201/9781351074988}. 62 | 63 | Abramowitz, M. and Stegun, I. A. (1972) 64 | \emph{Handbook of Mathematical Functions.} New York: Dover. 65 | Chapter 6: Gamma and Related Functions. 66 | 67 | Johnson, N. L., Kotz, S. and Balakrishnan, N. (1995) 68 | \emph{Continuous Univariate Distributions}, Volume 2, especially 69 | Chapter 25. Wiley, New York, \doi{10.1080/00224065.1996.11979675}. 70 | } 71 | \seealso{ 72 | \link{Distributions} for other standard distributions. 73 | } 74 | \examples{ 75 | 76 | #density 77 | curve(dgbeta(x, 3, 2, 3)) 78 | 79 | #cdf 80 | curve(pgbeta(x, 3, 2, 3)) 81 | } 82 | \keyword{distribution} 83 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | importFrom("utils", packageDescription) 2 | 3 | #for graphics 4 | importFrom("graphics", abline, plot, points,image, legend, lines, pairs) 5 | importFrom("grDevices", colorRampPalette) 6 | 7 | #user-friendly version of the MBBEFD distribution 8 | export(dmbbefd, pmbbefd, qmbbefd, rmbbefd, ecmbbefd, mmbbefd, tlmbbefd) 9 | export(dMBBEFD, pMBBEFD, qMBBEFD, rMBBEFD, ecMBBEFD, mMBBEFD, tlMBBEFD) 10 | 11 | #for internal use (fitting process) 12 | export(dmbbefd1, dmbbefd2, dMBBEFD1, dMBBEFD2, dgbeta1) 13 | 14 | export(g2a) #backward compatibility 15 | 16 | #C++ version of the MBBEFD distribution (not exported - debug only) 17 | #export(mbbefdExposure, rmbbefdC, qmbbefdC, dmbbefd2, pmbbefd2, dG) #deprecated functions 18 | #export(rmbbefdCpp, rMBBEFDCpp) 19 | 20 | #R version of the MBBEFD distribution (no longer exported) 21 | #export(dmbbefdR, pmbbefdR, qmbbefdR, rmbbefdR, ecmbbefdR, mmbbefdR, tlmbbefdR) 22 | #export(dMBBEFDR, pMBBEFDR, qMBBEFDR, rMBBEFDR, ecMBBEFDR, mMBBEFDR, tlMBBEFDR) 23 | 24 | #Swiss Re curves 25 | export(swissRe) 26 | 27 | 28 | #finite-support distributions 29 | importFrom("stats", dbeta, pbeta, qbeta, rbeta, 30 | dunif, punif, qunif, runif, 31 | rbinom, pgamma, 32 | optim, optimHess, constrOptim, integrate, optimize, 33 | cov2cor, median, quantile, var) 34 | importFrom("actuar", munif, levunif, mbeta, levbeta) #d,p,q,r functions in base R 35 | export(ecunif) 36 | export(ecbeta) 37 | #importFrom("gsl", dilog) #dilogarithm function used variance 38 | export(dstpareto, pstpareto, qstpareto, rstpareto, ecstpareto, mstpareto) 39 | export(dgbeta, pgbeta, qgbeta, rgbeta, ecgbeta, mgbeta) 40 | 41 | #one-inflated distributions (on the unit interval) 42 | export(doifun, poifun, qoifun, roifun, ecoifun, moifun, tloifun) 43 | export(doiunif, poiunif, qoiunif, roiunif, ecoiunif, moiunif, tloiunif) 44 | export(doibeta, poibeta, qoibeta, roibeta, ecoibeta, moibeta, tloibeta) 45 | export(doistpareto, poistpareto, qoistpareto, roistpareto, ecoistpareto, moistpareto, tloistpareto) 46 | export(doigbeta, poigbeta, qoigbeta, roigbeta, ecoigbeta, moigbeta, tloigbeta) 47 | 48 | #empirical total loss 49 | export(etl) 50 | 51 | #eecf class for empirical exposure curve function 52 | export(eecf) 53 | S3method(summary, eecf) 54 | S3method(print, eecf) 55 | S3method(print, summary.eecf) 56 | S3method(plot, eecf) 57 | S3method(lines, eecf) 58 | 59 | #new generic function for DR class similar to cdfcomp 60 | export(eccomp) 61 | 62 | #fitting methods 63 | importFrom("fitdistrplus", fitdist, mledist, mmedist) 64 | importFrom("alabama", constrOptim.nl) #only for MBBEFD 65 | export(fitDR) #fitDR class inheriting from fitdist class 66 | export(bootDR) #bootDR class inheriting from bootdist class 67 | 68 | #temporary 69 | importFrom("MASS", kde2d) 70 | 71 | importFrom("Rcpp", sourceCpp) 72 | useDynLib(mbbefd, .registration=TRUE) 73 | -------------------------------------------------------------------------------- /man/graph-eccomp.Rd: -------------------------------------------------------------------------------- 1 | \name{graph-eccomp} 2 | \alias{graph-eccomp} 3 | \alias{eccomp} 4 | 5 | \title{Graphical comparison of multiple fitted distributions} 6 | \description{ 7 | \code{eccomp} plots the empirical exposure curve distribution 8 | against fitted exposure curve functions. 9 | } 10 | 11 | \usage{ 12 | eccomp(ft, xlim, ylim, main, xlab, ylab, do.points=TRUE, 13 | datapch, datacol, fitlty, fitcol, addlegend = TRUE, 14 | legendtext, xlegend = "bottomright", 15 | ylegend = NULL, \dots) 16 | 17 | } 18 | \arguments{ 19 | \item{ft}{One \code{"DR"} object or a list of objects of class \code{"DR"}.} 20 | \item{xlim}{The \eqn{x}-limits of the plot.} 21 | \item{ylim}{The \eqn{y}-limits of the plot.} 22 | \item{main}{A main title for the plot, see also \code{\link{title}}.} 23 | \item{xlab}{A label for the \eqn{x}-axis, defaults to a description of \code{x}.} 24 | \item{ylab}{A label for the \eqn{y}-axis, defaults to a description of \code{y}.} 25 | \item{datapch}{An integer specifying a symbol to be used in plotting data points, 26 | see also \code{\link{points}}.} 27 | \item{datacol}{A specification of the color to be used in plotting data points.} 28 | \item{fitcol}{A (vector of) color(s) to plot fitted distributions. 29 | If there are fewer colors than fits they are recycled in the standard fashion.} 30 | \item{fitlty}{A (vector of) line type(s) to plot fitted distributions/densities. 31 | If there are fewer colors than fits they are recycled in the standard fashion. 32 | See also \code{\link{par}}.} 33 | \item{addlegend}{If \code{TRUE}, a legend is added to the plot.} 34 | \item{legendtext}{A character or expression vector of length \eqn{\geq 1} to appear 35 | in the legend, see also \code{\link{legend}}.} 36 | \item{xlegend, ylegend}{The \eqn{x} and \eqn{y} co-ordinates to be used to position 37 | the legend. They can be specified by keyword or in any way which is 38 | accepted by 'xy.coords': see \code{\link{legend}} for details.} 39 | \item{do.points}{logical; if \code{TRUE}, also draw points at the x-locations. 40 | Default is true. For large dataset (n > 1e4), \code{do.points} is ignored and no 41 | point is drawn.} 42 | \item{\dots}{Further graphical arguments passed to graphical functions used in cdfcomp, denscomp, 43 | ppcomp and qqcomp.} 44 | } 45 | 46 | \details{ 47 | \code{eccomp} provides a exposure curve plot of each fitted distribution 48 | along with the eecf. 49 | 50 | 51 | 52 | By default a legend is added to these plots. Many graphical arguments are optional, 53 | dedicated to personalize the plots, and fixed to default values if omitted. 54 | } 55 | 56 | \seealso{ 57 | See \code{\link{plot}}, \code{\link{legend}}, \code{\link{eecf}}. 58 | } 59 | 60 | 61 | 62 | \author{ 63 | Christophe Dutang. 64 | } 65 | 66 | \examples{ 67 | # (1) 68 | 69 | } 70 | 71 | \keyword{ distribution } 72 | -------------------------------------------------------------------------------- /R/graph-eccomp.R: -------------------------------------------------------------------------------- 1 | eccomp <- function(ft, xlim, ylim, main, xlab, ylab, do.points=TRUE, 2 | datapch, datacol, fitlty, fitcol, addlegend = TRUE, 3 | legendtext, xlegend = "bottomright", 4 | ylegend = NULL, ...) 5 | { 6 | if(inherits(ft, "DR")) 7 | { 8 | ft <- list(ft) 9 | }else if(!is.list(ft)) 10 | { 11 | stop("argument ft must be a list of 'DR' objects") 12 | }else 13 | { 14 | if(any(sapply(ft, function(x) !inherits(x, "DR")))) 15 | stop("argument ft must be a list of 'DR' objects") 16 | } 17 | 18 | nft <- length(ft) 19 | if (missing(datapch)) datapch <- 16 20 | if (missing(datacol)) datacol <- "black" 21 | if (missing(fitcol)) fitcol <- 2:(nft+1) 22 | if (missing(fitlty)) fitlty <- 1:nft 23 | fitcol <- rep(fitcol, length.out=nft) 24 | fitlty <- rep(fitlty, length.out=nft) 25 | 26 | if (missing(xlab)) 27 | xlab <- "data" 28 | if (missing(ylab)) ylab <- "G(x)" 29 | if (missing(main)) main <- paste("Emp. and theo. exposure curve(s)") 30 | 31 | # check legend parameters if added 32 | if(missing(legendtext)) 33 | { 34 | legendtext <- sapply(ft, function(x) x$distname) 35 | if(length(legendtext) != length(unique(legendtext))) 36 | legendtext <- paste(legendtext, sapply(ft, function(x) toupper(x$method)), sep="-") 37 | if(length(legendtext) != length(unique(legendtext))) 38 | legendtext <- paste(legendtext, 1:nft, sep="-") 39 | } 40 | 41 | mydata <- ft[[1]]$data 42 | distname <- ft[[1]]$distname 43 | n <- length(mydata) 44 | s <- sort(mydata) 45 | largedata <- (n > 1e4) 46 | 47 | if(missing(xlim)) 48 | { 49 | xmin <- min(mydata) 50 | xmax <- max(mydata) 51 | xlim <- c(xmin, xmax) 52 | } 53 | else 54 | { 55 | xmin <- xlim[1] 56 | xmax <- xlim[2] 57 | } 58 | 59 | verif.ftidata <- function(fti) 60 | { 61 | if (any(fti$data != mydata)) 62 | stop("All compared fits must have been obtained with the same dataset") 63 | invisible() 64 | } 65 | lapply(ft, verif.ftidata) 66 | 67 | # computation of each fitted exposure curve 68 | sfin <- seq(xmin, xmax, length.out=101) 69 | comput.fti <- function(i) 70 | { 71 | fti <- ft[[i]] 72 | para <- c(as.list(fti$estimate), as.list(fti$fix.arg)) 73 | distname <- fti$distname 74 | ecdistname <- paste("ec",distname,sep="") 75 | do.call(ecdistname, c(list(x=sfin), as.list(para))) 76 | 77 | } 78 | fittedec <- sapply(1:nft, comput.fti) 79 | 80 | #main plotting 81 | resec <- plot(eecf(x = mydata), main=main, xlab=xlab, ylab=ylab, xlim=xlim, 82 | ylim=ylim, col=datacol, do.points=do.points) 83 | #plot fitted densities 84 | for(i in 1:nft) 85 | lines(sfin, fittedec[,i], lty=fitlty[i], col=fitcol[i], ...) 86 | 87 | if(addlegend) 88 | { 89 | legend(x=xlegend, y=ylegend, bty="n", legend=legendtext, 90 | lty=fitlty, col=fitcol,...) 91 | } 92 | } -------------------------------------------------------------------------------- /tests/test-rng-mbbefd.R: -------------------------------------------------------------------------------- 1 | library(mbbefd) 2 | 3 | testfunc <- function(x) 4 | c(summary(x), sd=sd(x), tl=etl(x)) 5 | extensive <- TRUE 6 | extensive <- FALSE 7 | 8 | 9 | # test invalid param 10 | n <- 5 11 | a <- 0 12 | b <- -1/2 13 | mbbefd:::rmbbefdCpp(n, a, b) 14 | mbbefd:::rmbbefdR(n, a, b) 15 | g <- 1/2 16 | b <- 3 17 | 18 | mbbefd:::rMBBEFDCpp(n, g, b) 19 | mbbefd:::rMBBEFDR(n, g, b) 20 | 21 | 22 | #test of MBBEFD(a,b) distribution 23 | 24 | n <- 10 25 | a <- 0 26 | b <- 1/2 27 | 28 | mbbefd:::rmbbefdCpp(n, a, b) 29 | mbbefd:::rmbbefdR(n, a, b) 30 | if(extensive) 31 | { 32 | n <- 1e6 33 | print(testfunc(mbbefd:::rmbbefdCpp(n, a, b))) 34 | print(testfunc(mbbefd:::rmbbefdR(n, a, b))) 35 | } 36 | 37 | a <- 1/2 38 | b <- 1 39 | n <- 10 40 | 41 | mbbefd:::rmbbefdCpp(n, a, b) 42 | mbbefd:::rmbbefdR(n, a, b) 43 | if(extensive) 44 | { 45 | n <- 1e6 46 | print(testfunc(mbbefd:::rmbbefdCpp(n, a, b))) 47 | print(testfunc(mbbefd:::rmbbefdR(n, a, b))) 48 | } 49 | 50 | a <- -1/2 51 | b <- 3 52 | n <- 10 53 | 54 | mbbefd:::rmbbefdCpp(n, a, b) 55 | mbbefd:::rmbbefdR(n, a, b) 56 | if(extensive) 57 | { 58 | n <- 1e6 59 | print(testfunc(mbbefd:::rmbbefdCpp(n, a, b))) 60 | print(testfunc(mbbefd:::rmbbefdR(n, a, b))) 61 | } 62 | 63 | a <- Inf 64 | b <- 1/3 65 | n <- 10 66 | 67 | mbbefd:::rmbbefdCpp(n, a, b) 68 | mbbefd:::rmbbefdR(n, a, b) 69 | if(extensive) 70 | { 71 | n <- 1e6 72 | print(testfunc(mbbefd:::rmbbefdCpp(n, a, b))) 73 | print(testfunc(mbbefd:::rmbbefdR(n, a, b))) 74 | } 75 | 76 | 77 | 78 | 79 | #test of MBBEFD(g,b) distribution 80 | 81 | n <- 10 82 | g <- 1 83 | b <- 1/2 84 | 85 | mbbefd:::rMBBEFDCpp(n, g, b) 86 | mbbefd:::rMBBEFDR(n, g, b) 87 | if(extensive) 88 | { 89 | n <- 1e6 90 | print(testfunc(mbbefd:::rMBBEFDCpp(n, g, b))) 91 | print(testfunc(mbbefd:::rMBBEFDR(n, g, b))) 92 | } 93 | 94 | n <- 10 95 | g <- 2 96 | b <- 0 97 | 98 | mbbefd:::rMBBEFDCpp(n, g, b) 99 | mbbefd:::rMBBEFDR(n, g, b) 100 | if(extensive) 101 | { 102 | n <- 1e6 103 | print(testfunc(mbbefd:::rMBBEFDCpp(n, g, b))) 104 | print(testfunc(mbbefd:::rMBBEFDR(n, g, b))) 105 | } 106 | 107 | 108 | n <- 10 109 | g <- 2 110 | b <- 1/2 111 | 112 | mbbefd:::rMBBEFDCpp(n, g, b) 113 | mbbefd:::rMBBEFDR(n, g, b) 114 | if(extensive) 115 | { 116 | n <- 1e6 117 | print(testfunc(mbbefd:::rMBBEFDCpp(n, g, b))) 118 | print(testfunc(mbbefd:::rMBBEFDR(n, g, b))) 119 | } 120 | 121 | n <- 10 122 | g <- 2 123 | b <- 1 124 | 125 | mbbefd:::rMBBEFDCpp(n, g, b) 126 | mbbefd:::rMBBEFDR(n, g, b) 127 | if(extensive) 128 | { 129 | n <- 1e6 130 | print(testfunc(mbbefd:::rMBBEFDCpp(n, g, b))) 131 | print(testfunc(mbbefd:::rMBBEFDR(n, g, b))) 132 | } 133 | 134 | n <- 10 135 | g <- 2 136 | b <- 3 137 | 138 | mbbefd:::rMBBEFDCpp(n, g, b) 139 | mbbefd:::rMBBEFDR(n, g, b) 140 | if(extensive) 141 | { 142 | n <- 1e6 143 | print(testfunc(mbbefd:::rMBBEFDCpp(n, g, b))) 144 | print(testfunc(mbbefd:::rMBBEFDR(n, g, b))) 145 | } -------------------------------------------------------------------------------- /R/fitDR-bootstrap.R: -------------------------------------------------------------------------------- 1 | bootDR <- function(f, bootmethod="param", niter=1001, silent=TRUE) 2 | { 3 | if (!inherits(f, "DR")) 4 | stop("Use only with 'DR' objects") 5 | if (niter<10) 6 | stop("niter must be an integer above 10") 7 | bootmethod <- match.arg(bootmethod, c("param", "nonparam")) 8 | 9 | #simulate bootstrap data 10 | if (bootmethod == "param") { # parametric bootstrap 11 | rdistname <- paste("r", f$distname, sep="") 12 | if (!exists(rdistname, mode="function")) 13 | stop(paste("The ", rdistname, " function must be defined")) 14 | rdata <- do.call(rdistname, c(list(n=niter*f$n), as.list(f$estimate))) 15 | dim(rdata) <- c(f$n, niter) 16 | } 17 | else { # non parametric bootstrap 18 | rdata <- sample(f$data, size=niter*f$n, replace=TRUE) 19 | dim(rdata) <- c(f$n, niter) 20 | } 21 | 22 | #compute bootstrap estimates 23 | start <- as.list(f$estimate) #a named vector is no longer is accepted as starting values. 24 | #if (is.null(f$dots)) 25 | func <- function(iter) { 26 | res <- try(do.call(fitDR, list(x=rdata[, iter], dist=f$distname, start=start)), silent=silent) 27 | 28 | if(class(res)[1] == "try-error") 29 | return(c(rep(NA, length(start)), 100)) 30 | else 31 | return(c(res$estimate, res$convergence)) 32 | } 33 | #else 34 | # func <- function(iter) { 35 | # res <- do.call(fitDR, c(list(x=rdata[, iter], dist=f$distname, start=start, fix.arg=f$fix.arg), f$dots)) 36 | # return(c(res$estimate, res$convergence)) 37 | # } 38 | owarn <- getOption("warn") 39 | oerr <- getOption("show.error.messages") 40 | #print(owarn) 41 | #print(oerr) 42 | options(warn=ifelse(silent, -1, 0), show.error.messages=!silent) 43 | resboot <- sapply(1:niter, func) 44 | options(warn=owarn, show.error.messages=oerr) 45 | #print(owarn) 46 | #print(oerr) 47 | 48 | rownames(resboot) <- c(names(f$estimate), "convergence") 49 | if (length(resboot[, 1])>2) { 50 | estim <- data.frame(t(resboot)[, -length(resboot[, 1])]) 51 | bootCI <- cbind(apply(resboot[-length(resboot[, 1]), ], 1, median, na.rm=TRUE), 52 | apply(resboot[-length(resboot[, 1]), ], 1, quantile, 0.025, na.rm=TRUE), 53 | apply(resboot[-length(resboot[, 1]), ], 1, quantile, 0.975, na.rm=TRUE)) 54 | colnames(bootCI) <- c("Median", "2.5%", "97.5%") 55 | } 56 | else { 57 | estim <- as.data.frame(t(resboot)[, -length(resboot[, 1])]) 58 | names(estim) <- names(f$estimate) 59 | bootCI <- c(median(resboot[-length(resboot[, 1]), ], na.rm=TRUE), 60 | quantile(resboot[-length(resboot[, 1]), ], 0.025, na.rm=TRUE), 61 | quantile(resboot[-length(resboot[, 1]), ], 0.975, na.rm=TRUE)) 62 | names(bootCI) <- c("Median", "2.5%", "97.5%") 63 | } 64 | 65 | # code of convergence of the optimization function for each iteration 66 | converg <- t(resboot)[, length(resboot[, 1])] 67 | 68 | res <- structure(list(estim=estim, converg=converg, 69 | method=bootmethod, nbboot=niter, CI=bootCI, fitpart=f), 70 | class=c("bootDR", "bootdist")) 71 | res 72 | } -------------------------------------------------------------------------------- /tests/test-GB1.R: -------------------------------------------------------------------------------- 1 | library(mbbefd) 2 | 3 | #test of GB1 distribution 4 | 5 | 6 | 7 | 8 | #integral of the density 9 | integrate(dgbeta, 0, 1, shape0=1, shape1=3, shape2=3/2) 10 | integrate(dgbeta, 0, 1, shape0=1/2, shape1=3, shape2=3/2) 11 | integrate(dgbeta, 0, 1, shape0=2, shape1=3, shape2=3/2) 12 | 13 | z <- 0:10/10 14 | cbind(pi*z^(3*pi-1)*(1-z^pi)^(3/2-1)/beta(3, 3/2), dgbeta(z, pi, 3, 3/2)) 15 | cbind(dbeta(z^pi, 3, 3/2)*pi*z^(pi-1), dgbeta(z, pi, 3, 3/2)) 16 | cbind(pbeta(z^pi, 3, 3/2), pgbeta(z, pi, 3, 3/2)) 17 | cbind(qbeta(z, 3, 3/2)^(1/pi), qgbeta(z, pi, 3, 3/2)) 18 | 19 | 20 | #log argument 21 | 22 | cbind(dbeta(z, 3, 3/2, log=TRUE), dgbeta(z, 1, 3, 3/2, log=TRUE)) 23 | cbind(log(dgbeta(z, pi, 3, 3/2, log=FALSE)), dgbeta(z, pi, 3, 3/2, log=TRUE)) 24 | cbind(log(pgbeta(z, pi, 3, 3/2, log=FALSE)), pgbeta(z, pi, 3, 3/2, log=TRUE)) 25 | cbind(log(pgbeta(z, pi, 3, 3/2, log=FALSE, lower=TRUE)), pgbeta(z, pi, 3, 3/2, log=TRUE, lower=TRUE)) 26 | cbind(qgbeta(z, pi, 3, 3/2, log=FALSE), qgbeta(log(z), pi, 3, 3/2, log=TRUE)) 27 | cbind(qgbeta(z, pi, 3, 3/2, log=FALSE, lower=TRUE), qgbeta(log(z), pi, 3, 3/2, log=TRUE, lower=TRUE)) 28 | 29 | #RNG 30 | n <- 1e4 31 | x <- rgbeta(n, shape0=2, shape1=3, shape2=3/2) 32 | y <- rgbeta(n, shape0=pi, shape1=3, shape2=3/2) 33 | 34 | #test density 35 | z <- 0:100/100 36 | 37 | plot(density(x)); lines(z, dgbeta(z, shape0=2, shape1=3, shape2=3/2), col="red") 38 | plot(density(y)); lines(z, dgbeta(z, shape0=pi, shape1=3, shape2=3/2), col="red") 39 | 40 | #mode 41 | modeGB1 <- function(shape0, shape1, shape2) 42 | { 43 | if(shape1+shape2-1/shape0>1) 44 | ((shape1-1/shape0)/(shape1+shape2-1/shape0-1))^(1/shape0) 45 | else 46 | NaN 47 | } 48 | c(modeGB1(2, 3, 3/2), density(x)$x[which.max(density(x)$y)]) 49 | c(modeGB1(pi, 3, 3/2), density(y)$x[which.max(density(y)$y)]) 50 | 51 | #test CDF 52 | z <- 0:10/10 53 | cbind(ecdf(x)(z), pgbeta(z, shape0=2, shape1=3, shape2=3/2)) 54 | 55 | cbind(ecdf(y)(z), pgbeta(z, shape0=pi, shape1=3, shape2=3/2)) 56 | 57 | #plot(ecdf(x)); lines(z, pgbeta(z, shape0=2, shape1=3, shape2=3/2), col="red") 58 | #plot(ecdf(y)); lines(z, pgbeta(z, shape0=pi, shape1=3, shape2=3/2), col="red") 59 | 60 | #mean 61 | c(mean(x), mgbeta(1, shape0=2, shape1=3, shape2=3/2)) 62 | c(mean(y), mgbeta(1, shape0=pi, shape1=3, shape2=3/2)) 63 | 64 | #raw moment 65 | for(i in 2:4) 66 | { 67 | cat("E(X^", i, ")\n", sep="") 68 | print(c(mean(x^i), mgbeta(i, shape0=2, shape1=3, shape2=3/2))) 69 | print(c(mean(y^i), mgbeta(i, shape0=pi, shape1=3, shape2=3/2))) 70 | } 71 | 72 | #test limited expected value 73 | d <- 1/2 74 | s0 <- 2 75 | s1 <- 3 76 | s2 <- 3/2 77 | 78 | mean(pmin(x, d)) 79 | 80 | f <- function(x, d, shape0) dgbeta(x, shape0=shape0, shape1=3, shape2=3/2)*pmin(x,d) 81 | integrate(f, 0, 1, d=d, shape0=s0) 82 | 83 | 84 | 85 | #test EC 86 | f <- function(x, d, shape0) dgbeta(x, shape0=shape0, shape1=3, shape2=3/2)*pmin(x, d)/mgbeta(1, shape0=shape0, shape1=3, shape2=3/2) 87 | F <- function(d, shape0) sapply(d, function(d) integrate(f, 0, 1, d=d, shape0=shape0)$value) 88 | 89 | cbind(eecf(x)(z), ecgbeta(z, shape0=2, shape1=3, shape2=3/2), F(z, shape0=2)) 90 | 91 | cbind(eecf(y)(z), ecgbeta(z, shape0=pi, shape1=3, shape2=3/2), F(z, shape0=pi)) 92 | 93 | 94 | 95 | 96 | -------------------------------------------------------------------------------- /man/mbbefdDistribution.Rd: -------------------------------------------------------------------------------- 1 | \name{mbbefd-distr} 2 | \alias{mbbefd-distr} 3 | \alias{mbbefd} 4 | \alias{dmbbefd} 5 | \alias{pmbbefd} 6 | \alias{qmbbefd} 7 | \alias{rmbbefd} 8 | \alias{ecmbbefd} 9 | \alias{mmbbefd} 10 | \alias{tlmbbefd} 11 | 12 | \alias{dmbbefd1} 13 | \alias{dmbbefd2} 14 | 15 | 16 | \alias{MBBEFD} 17 | \alias{dMBBEFD} 18 | \alias{pMBBEFD} 19 | \alias{qMBBEFD} 20 | \alias{rMBBEFD} 21 | \alias{ecMBBEFD} 22 | \alias{mMBBEFD} 23 | \alias{tlMBBEFD} 24 | 25 | \alias{dMBBEFD1} 26 | \alias{dMBBEFD2} 27 | 28 | 29 | \title{ 30 | The MBBEFD distribution (two parametrizations) 31 | } 32 | \description{ 33 | These functions perform probabilistic analysis as well 34 | as random sampling on the MBBEFD distribution: 35 | the 1st parametrization MBBEFD(a,b) is implemented in \code{mbbefd}, 36 | the 2nd parametrization MBBEFD(g,b) is implemented in \code{MBBEFD}. 37 | We also provide raw moments, exposure curve function and total loss. 38 | } 39 | \usage{ 40 | 41 | dmbbefd(x, a, b, log=FALSE) 42 | pmbbefd(q, a, b, lower.tail = TRUE, log.p = FALSE) 43 | qmbbefd(p, a, b, lower.tail = TRUE, log.p = FALSE) 44 | rmbbefd(n, a, b) 45 | ecmbbefd(x, a, b) 46 | mmbbefd(order, a, b) 47 | tlmbbefd(a, b) 48 | 49 | dMBBEFD(x, g, b, log=FALSE) 50 | pMBBEFD(q, g, b, lower.tail = TRUE, log.p = FALSE) 51 | qMBBEFD(p, g, b, lower.tail = TRUE, log.p = FALSE) 52 | rMBBEFD(n, g, b) 53 | ecMBBEFD(x, g, b) 54 | mMBBEFD(order, g, b) 55 | tlMBBEFD(g, b) 56 | 57 | } 58 | 59 | \arguments{ 60 | \item{x, q}{ 61 | vector of quantiles. 62 | } 63 | \item{p}{ 64 | vector of probabilities. 65 | } 66 | \item{n}{ 67 | number of observations. If \code{length(n) > 1}, the length is take to be the number required. 68 | } 69 | \item{a, b, g}{ 70 | shape parameters. For \code{.mbbefd} functions, \code{g} is computed from \code{a}. 71 | } 72 | \item{order}{ 73 | order of the raw moment. 74 | } 75 | \item{log, log.p}{ 76 | logical; if \code{TRUE}, probabilities \code{p} are given as log(p). 77 | } 78 | \item{lower.tail}{ 79 | logical; if \code{TRUE} (default), probabilities are \eqn{P[X <= x]}, otherwise, \eqn{P[X> x]}. 80 | } 81 | 82 | 83 | } 84 | \details{ 85 | it shall be remebered that \eqn{g=\frac{1}{p_1}=\frac{a+b}{\left(a+1\right)*b}}. 86 | } 87 | \value{ 88 | A numeric value or a vector. 89 | } 90 | \references{ 91 | BERNEGGER, STEFAN (1997). 92 | \emph{The Swiss Re Exposure Curves And The MBBEFD Distribution Class}, 93 | ASTIN Bulletin, 27(1), pp99-111, \doi{https://doi.org/10.2143/AST.27.1.563208}. 94 | } 95 | \author{ 96 | Giorgio Spedicato, 97 | Dutang Christophe 98 | } 99 | \seealso{ 100 | \code{\link{swissRe}}, \code{\link{exposureCurve}}. 101 | } 102 | \examples{ 103 | #1st parametrization 104 | # 105 | aPar=0.2 106 | bPar=0.04 107 | rmbbefd(n=10,a=aPar,b=bPar) #for random generation 108 | qmbbefd(p=0.7,a=aPar,b=bPar) #for quantiles 109 | dmbbefd(x=0.5,a=aPar,b=bPar) #for density 110 | pmbbefd(q=0.5,a=aPar,b=bPar) #for distribution function 111 | 112 | #2nd parametrization 113 | # 114 | gPar=2 115 | bPar=0.04 116 | rMBBEFD(n=10,g=gPar,b=bPar) #for random generation 117 | qMBBEFD(p=0.7,g=gPar,b=bPar) #for quantiles 118 | dMBBEFD(x=0.5,g=gPar,b=bPar) #for density 119 | pMBBEFD(q=0.5,g=gPar,b=bPar) #for distribution function 120 | 121 | 122 | } 123 | 124 | -------------------------------------------------------------------------------- /R/fitDR-prefit.R: -------------------------------------------------------------------------------- 1 | 2 | #search good starting values 3 | prefitDR.mle <- function(x, dist, control=list(trace=0, REPORT=1, maxit=100), ...) 4 | { 5 | if(dist == "mbbefd") 6 | { 7 | 8 | prefit1 <- mledist(x, distr="mbbefd1", optim.method="BFGS", start=list(a=0, b=0), 9 | silent=TRUE, control=control, ...) 10 | prefit2 <- mledist(x, distr="mbbefd2", optim.method="BFGS", start=list(a=0, b=0), 11 | silent=TRUE, control=control, ...) 12 | 13 | if(prefit1$convergence %in% 0:1) #either successful or reached the iter limit 14 | { 15 | initpar1 <- c(Trans.m10(prefit1$estimate["a"]), Trans.1Inf(prefit1$estimate["b"])) 16 | }else 17 | { 18 | initpar1 <- c(NA, NA) 19 | } 20 | 21 | if(prefit2$convergence %in% 0:1) 22 | { 23 | initpar2 <- c(Trans.0Inf(prefit2$estimate["a"]), Trans.01(prefit2$estimate["b"])) 24 | }else 25 | { 26 | initpar2 <- c(NA, NA) 27 | } 28 | 29 | list(initpar1, initpar2) 30 | 31 | }else if(dist == "MBBEFD") 32 | { 33 | #no constraint for the new param 34 | prefit1 <- mledist(x, distr="MBBEFD1", optim.method="BFGS", start=list(g=0, b=0), 35 | silent=TRUE, control=control, ...) 36 | 37 | constrOptim2 <- function(par, fn, gr=NULL, ui, ci, ...) 38 | constrOptim(theta=unlist(par), f=fn, grad=gr, ui=ui, ci=ci, ...) 39 | #constraint is g+b < 0 <=> -g-b > 0 (new param) 40 | prefit2 <- mledist(x, distr="MBBEFD2", optim.method="BFGS", custom.optim=constrOptim2, 41 | start=list(g=-1, b=0), ui = cbind(-1, -1), ci = 0, 42 | silent=TRUE, control=control, ...) 43 | if(prefit1$convergence %in% 0:1) #either successful or reached the iter limit 44 | { 45 | initpar1 <- c(Trans.1Inf(prefit1$estimate["g"]), Trans.1Inf(prefit1$estimate["b"])) 46 | }else 47 | { 48 | initpar1 <- c(NA, NA) 49 | } 50 | 51 | if(prefit2$convergence %in% 0:1) 52 | { 53 | initpar2 <- c(Trans.1Inf(prefit2$estimate["g"]), Trans.01(prefit2$estimate["b"])) 54 | }else 55 | { 56 | initpar2 <- c(NA, NA) 57 | } 58 | 59 | list(initpar1, initpar2) 60 | 61 | }else if(dist == "oigbeta") 62 | { 63 | x <- x[x != 1] 64 | prefit <- mledist(x, distr="gbeta1", optim.method="BFGS", silent=TRUE, control=control, 65 | start=list(shape0=0, shape1=0, shape2=0)) 66 | if(prefit$convergence %in% 0:1) 67 | { 68 | initpar <- Trans.0Inf(prefit$estimate) 69 | }else 70 | { 71 | initpar <- c(NA, NA) 72 | } 73 | initpar 74 | } 75 | } 76 | 77 | #Transformed distribution (internal use) 78 | 79 | #MBBEFD(a,b) 80 | #domain : (a,b) in (-1, 0) x (1, +Inf) 81 | dmbbefd1 <- function(x, a, b, log=FALSE) 82 | dmbbefd(x, Trans.m10(a), Trans.1Inf(b), log=log) 83 | #domain : (a,b) in (0, +Inf) x (0, 1) 84 | dmbbefd2 <- function(x, a, b, log=FALSE) 85 | dmbbefd(x, Trans.0Inf(a), Trans.01(b), log=log) 86 | 87 | #MBBEFD(a,b) 88 | #domain : (g,b) in (1, +Inf) x (1, +Inf) 89 | #with gb > 1 (old param) : always verified in param 90 | dMBBEFD1 <- function(x, g, b, log=FALSE) 91 | dMBBEFD(x, Trans.1Inf(g), Trans.1Inf(b), log=log) 92 | #domain : (g,b) in (1, +Inf) x (0, 1) 93 | # with gb < 1 (old param) : g < -b in new param 94 | dMBBEFD2 <- function(x, g, b, log=FALSE) 95 | dMBBEFD(x, Trans.1Inf(g), Trans.01(b), log=log) 96 | 97 | 98 | #OI-GB1 99 | dgbeta1 <- function(x, shape0, shape1, shape2, log=FALSE) 100 | dgbeta(x, Trans.0Inf(shape0), Trans.0Inf(shape1), Trans.0Inf(shape2), log=log) 101 | -------------------------------------------------------------------------------- /R/distr-GB1.R: -------------------------------------------------------------------------------- 1 | #d, p, q, r function for generalized beta distribution of the first kind 2 | #(no location and scale paramater) 3 | 4 | #should it be dstpareto01? 5 | dgbeta <- function(x, shape0, shape1, shape2, log=FALSE) 6 | { 7 | if(!is.numeric(shape0) || !is.numeric(shape1) || !is.numeric(shape0)) 8 | stop("non numeric argument.") 9 | if(shape0 < 0 || shape1 < 0 || shape2 < 0) 10 | return(rep(NaN, length(x))) 11 | if(log) 12 | { 13 | res <- log(shape0)+(shape0-1)*log(x)+dbeta(x^(shape0), shape1, shape2, log=log) 14 | res[x < 0 | x > 1] <- -Inf 15 | }else 16 | { 17 | res <- shape0*x^(shape0-1)*dbeta(x^(shape0), shape1, shape2, log=FALSE) 18 | res[x < 0 | x > 1] <- 0 19 | } 20 | res 21 | } 22 | 23 | pgbeta <- function(q, shape0, shape1, shape2, lower.tail = TRUE, log.p = FALSE) 24 | { 25 | if(!is.numeric(shape0) || !is.numeric(shape1) || !is.numeric(shape0)) 26 | stop("non numeric argument.") 27 | if(shape0 < 0 || shape1 < 0 || shape2 < 0) 28 | return(rep(NaN, length(q))) 29 | res <- pbeta(q^shape0, shape1, shape2, lower.tail=TRUE, log.p=FALSE) 30 | if(!lower.tail) 31 | res <- 1-res 32 | if(log.p) 33 | res <- log(res) 34 | res 35 | } 36 | 37 | 38 | qgbeta <- function(p, shape0, shape1, shape2, lower.tail = TRUE, log.p = FALSE) 39 | { 40 | if(!is.numeric(shape0) || !is.numeric(shape1) || !is.numeric(shape0)) 41 | stop("non numeric argument.") 42 | if(shape0 < 0 || shape1 < 0 || shape2 < 0) 43 | return(rep(NaN, length(p))) 44 | if(!lower.tail) 45 | p <- 1-p 46 | if(log.p) 47 | p <- exp(p) 48 | qbeta(p, shape1, shape2, lower.tail=TRUE, log.p=FALSE)^(1/shape0) 49 | } 50 | 51 | rgbeta <- function(n, shape0, shape1, shape2) 52 | { 53 | if(!is.numeric(shape0) || !is.numeric(shape1) || !is.numeric(shape0)) 54 | stop("non numeric argument.") 55 | n <- ifelse(length(n)>1, length(n), n) 56 | if(shape0 < 0 || shape1 < 0 || shape2 < 0) 57 | return(rep(NaN, n)) 58 | rbeta(n, shape1, shape2)^(1/shape0) 59 | } 60 | 61 | 62 | ecgbeta <- function(x, shape0, shape1, shape2) 63 | { 64 | if(!is.numeric(shape0) || !is.numeric(shape1) || !is.numeric(shape0)) 65 | stop("non numeric argument.") 66 | if(shape0 < 0 || shape1 < 0 || shape2 < 0) 67 | return(rep(NaN, length(x))) 68 | 69 | cst2 <- beta(shape1, 1/shape0)/beta(shape1 + shape2, 1/shape0) 70 | 71 | pbeta(x^shape0, shape1+1/shape0, shape2) + x*(1 - pbeta(x^shape0, shape1, shape2))*cst2 72 | } 73 | 74 | mgbeta <- function(order, shape0, shape1, shape2) 75 | { 76 | if(!is.numeric(shape0) || !is.numeric(shape1) || !is.numeric(shape0)) 77 | stop("non numeric argument.") 78 | if(shape0 < 0 || shape1 < 0 || shape2 < 0) 79 | return(rep(NaN, length(order))) 80 | 81 | beta(shape1+shape2, order/shape0) / beta(shape1, order/shape0) 82 | } 83 | 84 | 85 | ################### 86 | #internal functions 87 | 88 | #incomplete beta function 89 | betainc <- function(x, a,b) pbeta(x, a, b)*beta(a,b) 90 | 91 | 92 | #Theil index, see package ineq for other income index (e.g. Gini coefficient) 93 | Theil.theo <- function(shape0, shape1, shape2) 94 | { 95 | EX <- beta(shape1+shape2, 1/shape0) / beta(shape1, 1/shape0) 96 | 1/shape0*(digamma(shape1+1/shape0)-digamma(shape1+shape2+ 1/shape0)) - log(EX) 97 | } 98 | 99 | Theil.theo.shape0 <- function(shape0, obs) 100 | { 101 | #compute shape1/shape2 on a rescaled sample and moment estimator 102 | obs <- obs^shape0 103 | n <- length(obs) 104 | m <- mean(obs) 105 | v <- (n - 1)/n*var(obs) 106 | aux <- m*(1-m)/v - 1 107 | shape1 <- m*aux 108 | shape2 <- (1-m)*aux 109 | 110 | Theil.theo(shape0, shape1, shape2) 111 | } 112 | -------------------------------------------------------------------------------- /R/util-empiricalfunctions.R: -------------------------------------------------------------------------------- 1 | ###################################################################### 2 | # Empirical sample-based functions 3 | ###################################################################### 4 | 5 | 6 | #empirical exposure curve 7 | #in the spirit of ecdf() 8 | eecf <- function(x) 9 | { 10 | x <- sort(x) # drops NAs 11 | n <- length(x) 12 | if(n < 1) stop("'x' must have 1 or more non-missing values") 13 | 14 | Gx <- cumsum(x)/n + x*(n-(1:n))/n #numerator 15 | Gx <- Gx/mean(x) #denominator 16 | 17 | f <- function(d) 18 | mean(pmin(x, d))/mean(x) 19 | rval <- Vectorize(f, "d") 20 | 21 | class(rval) <- c("eecf", class(rval)) 22 | assign("Gx", Gx, envir=environment(rval)) 23 | assign("x", x, envir=environment(rval)) 24 | assign("nobs", n, envir=environment(rval)) # e.g. to reconstruct rank(x) 25 | attr(rval, "call") <- sys.call() 26 | rval 27 | } 28 | 29 | print.eecf <- function (x, digits = getOption("digits") - 2L, ...) 30 | { 31 | numform <- function(x) paste(formatC(x, digits = digits), collapse = ", ") 32 | cat("Empirical Exposure Curve Function \nCall: ") 33 | print(attr(x, "call"), ...) 34 | xx <- environment(x)$"x" 35 | n <- environment(x)$"nobs" 36 | 37 | i1 <- 1L:min(3L,n) 38 | i2 <- if(n >= 4L) max(4L, n-1L):n else integer() 39 | cat(" x[1:",n,"] = ", numform(xx[i1]), 40 | if(n>3L) ", ", if(n>5L) " ..., ", numform(xx[i2]), "\n", sep = "") 41 | invisible(x) 42 | } 43 | 44 | summary.eecf <- function(object, ...) 45 | { 46 | xx <- environment(object)$"x" 47 | n <- environment(object)$"nobs" 48 | 49 | header <- paste("Empirical Exposure Curve Function: ", n, 50 | "unique values with summary\n") 51 | structure(summary(xx, digits = max(3, getOption("digits")-3), ...), 52 | header = header, class = "summary.eecf") 53 | } 54 | 55 | print.summary.eecf <- function(x, ...) 56 | { 57 | cat(attr(x, "header")) 58 | y <- unclass(x); attr(y, "header") <- NULL 59 | print(y, ...) 60 | invisible(x) 61 | } 62 | 63 | plot.eecf <- function(x, ..., ylab="Gn(x)", do.points=TRUE, 64 | col.01line = "gray70", pch = 19, main=NULL, 65 | ylim=NULL, add=FALSE) 66 | { 67 | n <- environment(x)$"nobs" 68 | xx <- environment(x)$"x" 69 | yy <- environment(x)$"Gx" 70 | #add left-hand point 71 | if(length(xx) != n) 72 | stop("wrong x attribute") 73 | xx <- c(0, xx) 74 | yy <- c(0, yy) 75 | 76 | #from plot.stepfun called for plot.ecdf 77 | if(missing(main)) 78 | main <- { 79 | cl <- attr(x,"call") 80 | deparse(if(!is.null(cl))cl else sys.call()) 81 | } 82 | if(missing(ylim)) 83 | ylim <- c(0, 1) 84 | 85 | #unlike ecdf, eecf is a continuous function 86 | if(!add) 87 | { 88 | plot(xx, yy, type = "l", ylab = ylab, main=main, ylim=ylim, ...) 89 | if(do.points) points(xx[-1], yy[-1], pch = pch, ...) 90 | abline(h = 1, col = col.01line, lty = 2) 91 | abline(a = 0, b = 1, col = col.01line, lty = 2) 92 | }else 93 | { 94 | lines(xx, yy, type="l", ...) 95 | if(do.points) points(xx[-1], yy[-1], pch = pch, ...) 96 | } 97 | #terminates with invisible() 98 | } 99 | 100 | lines.eecf <- function(x, ...) 101 | plot(x, add=TRUE, ...) 102 | 103 | 104 | 105 | #total loss 106 | etl <- function(x, na.rm = FALSE) 107 | mean(x == 1, na.rm = na.rm, trim=0) 108 | 109 | ################### 110 | #internal functions 111 | 112 | #Theil index, see package ineq for other income index (e.g. Gini coefficient) 113 | Theil.emp <- function(x, na.rm = FALSE) 114 | mean(x/mean(x, na.rm = na.rm, trim=0)*log(x/mean(x, na.rm = na.rm, trim=0)), 115 | na.rm = na.rm, trim=0) 116 | -------------------------------------------------------------------------------- /src/mbbefdRcppCode.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | using namespace Rcpp; 4 | 5 | 6 | //' Get a parameter known g and b 7 | //' 8 | //' \code{g2a} returns the a parameter known g and b 9 | //' 10 | //' @param g the g parameter 11 | //' @param b the b parameter 12 | //' 13 | //' @return a real value 14 | //' 15 | //' @examples 16 | //' 17 | //' g2a(10,2) 18 | //' 19 | //' @export 20 | // [[Rcpp::export]] 21 | double g2a(double g, double b) { 22 | double out; 23 | out = ( ( g - 1 ) * b) / ( 1 - g * b ); 24 | return out; 25 | } 26 | 27 | 28 | //' random number generation - 1st param 29 | //' 30 | //' \code{rmbbefdC} generates random variates distribution parameters a and b 31 | //' 32 | //' @param n: the number of random variates 33 | //' @param a: first shape parameter 34 | //' @param b: second shape parameter 35 | //' 36 | //' @return a vector of real values 37 | //' 38 | //' @example 39 | //' 40 | //' rmbbefdC2(n=10, a=.2, b=.05) 41 | 42 | // [[Rcpp::export(.rmbbefdC)]] 43 | NumericVector rmbbefdC(int n, double a, double b) { 44 | 45 | NumericVector out(n); 46 | double u, pab; 47 | if(a == 0 || b == 1 || !R_FINITE(b) || b == 0 || a == -1) //Dirac 48 | { 49 | for(int i=0; i 0) 53 | out[i] = 1.0; 54 | else 55 | out[i] = 0.0; 56 | } 57 | }else if(!R_FINITE(a)) 58 | { 59 | for(int i=0; i 1-b) 63 | out[i] = 1.0; 64 | else 65 | out[i] = log(1-u)/log(b); 66 | } 67 | }else if(a +1 >0 && b > 0 && a*(1-b) > 0) 68 | { 69 | pab = (a+1)*b/(a+b); 70 | for(int i=0; i 1-pab) 74 | out[i] = 1.0; 75 | else 76 | out[i] = log((1-u)*a/(a+u))/log(b); 77 | } 78 | }else 79 | { 80 | for(int i=0; i 0) 117 | out[i] = 1.0; 118 | else 119 | out[i] = 0.0; 120 | } 121 | }else if(b*g == 1 && b < 1) //bg=1 122 | { 123 | for(int i=0; i 1-b) 127 | out[i] = 1.0; 128 | else 129 | out[i] = log(1-u)/log(b); 130 | } 131 | }else if(g > 1 && b == 1) //b=1 132 | { 133 | for(int i=0; i 1-1/g) 137 | out[i] = 1.0; 138 | else 139 | out[i] = u/((1-u)*(g-1)); 140 | } 141 | }else if(b > 0 & g > 1) 142 | { 143 | for(int i=0; i 1-1/g) 147 | out[i] = 1.0; 148 | else 149 | out[i] = 1-log((g*b-1)/(g-1) + (1-b)/((1-u)*(g-1)))/log(b); 150 | } 151 | }else 152 | { 153 | for(int i=0; i D2 9 | library(gsl) 10 | f <- function(x) log(1-x)/x 11 | g <- 3 12 | b <- 1/4 13 | integrate(f, b*(g-1)/(g*b-1), (g-1)/(g*b-1)) 14 | -dilog((g-1)/(g*b-1)) + dilog(b*(g-1)/(g*b-1)) 15 | 16 | #Formula 2 -> D1 17 | g <- 3 18 | b <- 4 19 | integrate(f, b*(g-1)/(g*b-1), (g-1)/(g*b-1)) 20 | -dilog((g-1)/(g*b-1)) + dilog(b*(g-1)/(g*b-1)) 21 | 22 | #formula 2 -> D2 23 | 24 | f <- function(x) log(1+x*(g-1)/(1-g*b))/x 25 | g <- 3 26 | b <- 1/4 27 | integrate(f, b, 1) 28 | -dilog((g-1)/(g*b-1)) + dilog(b*(g-1)/(g*b-1)) 29 | 30 | #formula 2 -> D2 31 | 32 | f <- function(x) log(1-g*b+x*(g-1))/x 33 | g <- 3 34 | b <- 1/4 35 | integrate(f, b, 1) 36 | -dilog((g-1)/(g*b-1)) + dilog(b*(g-1)/(g*b-1)) - log(1-g*b)*log(b) 37 | 38 | 39 | 40 | #Formula 3 41 | f <- function(x, g, b) 42 | log(x)/x/( (g-1)*x+1-g*b ) 43 | 44 | I <- function(g, b) 45 | { 46 | temp <- dilog(b*(g-1)/(g*b-1)) - dilog((g-1)/(g*b-1)) 47 | (log(b)*log(abs(1-b)) - log(b)^2/2 +temp - log(abs(1-g*b))*log(b) )/(1-g*b) 48 | } 49 | 50 | b <- 1/4 51 | integrate(f, b, 1, g=3, b=b)$value 52 | I(g=3, b=b) 53 | 54 | b <- 4 55 | integrate(f, b, 1, g=3, b=b)$value 56 | I(g=3, b=b) 57 | 58 | 59 | #Formula second order moment D3 60 | f <- function(x) 61 | 1/(1+(g-1)*sqrt(x)) 62 | 63 | I <- function(g) 64 | 2/(g-1)-2*log(g)/(g-1)^2 65 | 66 | g <- 3.5 67 | integrate(f, 0, 1) 68 | I(3.5) 69 | 70 | 71 | #formula of regularity conditions - Lemma B1 72 | 73 | f <- function(x) 74 | (a+b^x)^m 75 | 76 | m <- 1; a <- 3; b <- 1/2 77 | integrate(f, 0, 1) 78 | m <- 2; a <- 3; b <- 1/2 79 | integrate(f, 0, 1) 80 | m <- 3; a <- 3; b <- 1/2 81 | integrate(f, 0, 1) 82 | 83 | I <- function(m, a, b) 84 | { 85 | if(m == 0) 86 | return(1) 87 | if(m > 0) 88 | { 89 | k <- 1:m 90 | return(a^m+ sum(choose(m,k)*a^(m-k)/log(b)*(b^k/k - 1/k))) 91 | }else 92 | { 93 | m <- -m 94 | k <- 1:(m-1) 95 | res <- 1/a^{m} - {log({a+b}/{a+1})}/{a^{m}*log(b)} 96 | if(m >= 2) 97 | res <- res + sum({-1}/{a^k*log(b)*(-m+k)}*({1}/{(a+b)^{m-k}} - {1}/{(a+1)^{m-k}})) 98 | return(res) 99 | } 100 | } 101 | I(1, a, b) 102 | I(2, a, b) 103 | I(3, a, b) 104 | 105 | g <- function(x) 106 | (a+b^x)^(-m) 107 | m <- 1; a <- 3; b <- 1/2 108 | integrate(g, 0, 1) 109 | I(-1, a, b) 110 | m <- 2; a <- 3; b <- 1/2 111 | integrate(g, 0, 1) 112 | I(-2, a, b) 113 | m <- 3; a <- 3; b <- 1/2 114 | integrate(g, 0, 1) 115 | I(-3, a, b) 116 | 117 | 118 | 119 | J <- function(m, a, b) 120 | { 121 | L2ab <- mbbefd:::gendilog(a,b) 122 | if(m == 0) 123 | return(1) 124 | if(m == 1) 125 | return(1/(2*a)-(log(a+b) - L2ab)/(a*log(b))) 126 | if(m == 2) 127 | return(1/a^2/2-log(a+b)/a^2/log(b)+log((a+b)/(a+1))/a^2/log(b)^2 + L2ab/a^2/log(b)-b/log(b)/a^2/(a+b)) 128 | k <- 1:m 129 | J(m-1, a, b)/a - 1/log(b)/a/(-m+1)/(a+b)^{m-1} + I(-m+1, a, b)/log(b)/a/(-m+1) 130 | } 131 | 132 | g <- function(x) 133 | x/(a+b^x)^(m) 134 | 135 | m <- 1; a <- 3; b <- 1/2 136 | integrate(g, 0, 1) 137 | J(1, a, b) 138 | m <- 2; a <- 3; b <- 1/2 139 | integrate(g, 0, 1) 140 | J(2, a, b) 141 | m <- 3; a <- 3; b <- 1/2 142 | integrate(g, 0, 1) 143 | J(3, a, b) 144 | m <- 4; a <- 3; b <- 1/2 145 | integrate(g, 0, 1) 146 | J(4, a, b) 147 | 148 | 149 | #formula of regularity conditions - Lemma B2 150 | f <- function(x) 151 | b^x*log(b)/((a+b^x)^m) 152 | 153 | I <- function(m, a, b) 154 | { 155 | if(m == 1) 156 | return(log((a+b)/(a+1))) 157 | 1/(-m+1)*(1/(a+b)^{m-1} - 1/(a+1)^{m-1}) 158 | } 159 | 160 | m <- 1; a <- 3; b <- 1/2 161 | integrate(f, 0, 1) 162 | I(1, a, b) 163 | 164 | m <- 2; a <- 3; b <- 1/2 165 | integrate(f, 0, 1) 166 | I(2, a, b) 167 | 168 | 169 | #formula of regularity conditions - Lemma B3 170 | 171 | 172 | f <- function(x) 173 | x*b^x*log(b)/(a+b^x)^m 174 | 175 | 176 | 177 | I <- function(m, a, b) 178 | { 179 | if(m == 1) 180 | return(log(a+b)-mbbefd:::gendilog(a,b)) 181 | res <- b/a/(a+b) - log((a+b)/(a+1))/a/log(b) 182 | if(m>2) 183 | { 184 | l <- 1:(m-2) 185 | res <- res - sum(1/a^l/log(b)/(m-1)/(-m+1+l)*(1/(a+b)^(m-1-l) - 1/(a+1)^(m-1-l)) ) 186 | } 187 | res 188 | } 189 | 190 | m <- 1; a <- 3; b <- 1/2 191 | integrate(f, 0, 1) 192 | I(m, a,b) 193 | 194 | m <- 2; a <- 3; b <- 1/2 195 | integrate(f, 0, 1) 196 | I(m, a,b) 197 | 198 | m <- 3; a <- 3; b <- 1/2 199 | integrate(f, 0, 1) 200 | I(m, a,b) 201 | 202 | m <- 4; a <- 3; b <- 1/2 203 | integrate(f, 0, 1) 204 | I(m, a,b) 205 | 206 | 207 | #formula of regularity conditions - Lemma B4 208 | 209 | f <- function(x) 210 | x^2*b^x*log(b)/(a+b^x)^m 211 | 212 | I <- function(m, a, b) 213 | { 214 | L2ab <- mbbefd:::gendilog(a,b) 215 | 216 | if(m == 2) 217 | res <- -1/(a+b)+1/a+2/a/log(b)*(-log(a+b)+L2ab) 218 | else if(m == 3) 219 | res <- -1/2/(a+b)^2+1/a^2/2-log(a+b)/a^2/log(b)+log((a+b)/(a+1))/a^2/log(b)^2 + L2ab/a^2/log(b)-b/log(b)/a^2/(a+b) 220 | else 221 | res <- NA 222 | res 223 | } 224 | 225 | m <- 2; a <- 3.1; b <- 1/2 226 | integrate(f, 0, 1) 227 | I(m, a,b) 228 | 229 | m <- 3; a <- 3.1; b <- 1/2 230 | integrate(f, 0, 1) 231 | I(m, a,b) 232 | -------------------------------------------------------------------------------- /tests/test-fit-gbeta.R: -------------------------------------------------------------------------------- 1 | library(mbbefd) 2 | library(fitdistrplus) 3 | 4 | #____________________________________________________________ 5 | #gbeta 6 | n <- 1e3 7 | nboot <- 100 8 | nboot <- 10 9 | set.seed(12345) 10 | x <- rgbeta(n, 2, 2, 5/2) 11 | 12 | initpar <- list(shape0=2, shape1=2, shape2=5/2) 13 | 14 | if(FALSE) 15 | { 16 | #____________________________________________________________ 17 | #test all computation methods 18 | ctr <- list(trace=0, REPORT=1, maxit=1000) 19 | reslist <- NULL 20 | for(meth in c("BFGS", "Nelder", "CG")) #CG with FR update 21 | { 22 | nograd$time <- system.time(nograd <- mledist(x, dist="gbeta", optim.method=meth, 23 | control=ctr, start=initpar))[3] 24 | reslist <- c(reslist, list(nograd)) 25 | } 26 | for(type in 2:3) #CG with PR or BS updates 27 | { 28 | nograd$time <- system.time(nograd <- mledist(x, dist="gbeta", optim.method="CG", 29 | control=c(ctr, type=type), start=initpar))[3] 30 | reslist <- c(reslist, list(nograd)) 31 | } 32 | fullname <- c("BFGS", "NM", paste("CG", c("FR", "PR", "BS"))) 33 | names(reslist) <- fullname 34 | 35 | dgbeta2 <- function(x, shape0, shape1, shape2, log=FALSE) 36 | dgbeta(x, exp(shape0), exp(shape1), exp(shape2), log=log) 37 | 38 | initpar2 <- lapply(initpar, log) 39 | 40 | for(meth in c("BFGS", "Nelder", "CG")) #CG with FR update 41 | { 42 | nograd$time <- system.time(nograd <- mledist(x, dist="gbeta2", optim.method="BFGS", 43 | control=ctr, start=initpar2))[3] 44 | nograd$estimate <- exp(nograd$estimate) 45 | reslist <- c(reslist, list(nograd)) 46 | } 47 | for(type in 2:3) #CG with PR or BS updates 48 | { 49 | nograd$time <- system.time(nograd <- mledist(x, dist="gbeta2", optim.method="CG", 50 | control=c(ctr, type=type), start=initpar2))[3] 51 | nograd$estimate <- exp(nograd$estimate) 52 | reslist <- c(reslist, list(nograd)) 53 | } 54 | names(reslist)[(length(fullname)+1):length(reslist)] <- paste("exp.", fullname) 55 | 56 | getval <- function(x) 57 | c(x$estimate, loglik=x$loglik, x$counts, x$time) 58 | 59 | resNM <- sapply(reslist[grep("NM", names(reslist))], getval) 60 | resCG <- sapply(reslist[grep("CG", names(reslist))], getval) 61 | resBFGS <- sapply(reslist[grep("BFGS", names(reslist))], getval) 62 | rownames(resNM) <- rownames(resCG) <- rownames(resBFGS) <- c(paste("fitted", c("shape0", "shape1", "shape2")), "fitted loglik", "func. eval. nb.", "grad. eval. nb.", "time (sec)") 63 | 64 | 65 | #____________________________________________________________ 66 | #empirical check of the log-likelihood computation 67 | head(cbind(do.call("dgbeta", c(list(x), initpar, NULL, log=TRUE)), 68 | log(do.call("dgbeta", c(list(x), initpar, NULL) ) ) 69 | )) 70 | colSums(cbind(do.call("dgbeta", c(list(x), initpar, NULL, log=TRUE)), 71 | log(do.call("dgbeta", c(list(x), initpar, NULL) ) ) 72 | )) 73 | 74 | #____________________________________________________________ 75 | #test with starting values equal theoretical values 76 | 77 | f1 <- fitDR(x, "oigbeta", "mle") 78 | 79 | f1 <- fitdist(x, "gbeta", method="mle", start=initpar) # , control=list(trace=3, REPORT=1)) 80 | summary(f1) 81 | cdfcomp(f1, do.points=FALSE, ylogscale = TRUE) 82 | lines(0:100/100, pgbeta(0:100/100, 2, 2, 5/2), col="green") 83 | 84 | denscomp(f1) 85 | lines(0:100/100, dgbeta(0:100/100, 2, 2, 5/2), col="green") 86 | 87 | #____________________________________________________________ 88 | #look at the log-likelihood function around the estimated value 89 | par(mfrow=c(1,3)) 90 | llsurface(plot.min=c(0.1, 0.1), plot.max=c(5, 4), nlevels=20, 91 | plot.arg=c("shape1", "shape2"), fix.arg=as.list(f1$estimate[1]), 92 | plot.np=50, obs=x, distr="gbeta", plot.type="contour") 93 | points(f1$estimate["shape1"], f1$estimate["shape2"], pch="+", col="red") 94 | points(2, 5/2, pch="x", col="green") 95 | llsurface(plot.min=c(0.1, 0.1), plot.max=c(6, 4), nlevels=20, 96 | plot.arg=c("shape0", "shape2"), fix.arg=as.list(f1$estimate[2]), 97 | plot.np=50, obs=x, distr="gbeta", plot.type="contour") 98 | points(f1$estimate["shape0"], f1$estimate["shape2"], pch="+", col="red") 99 | points(2, 5/2, pch="x", col="green") 100 | llsurface(plot.min=c(0.1, 0.1), plot.max=c(5, 6), nlevels=20, 101 | plot.arg=c("shape1", "shape0"), fix.arg=as.list(f1$estimate[3]), 102 | plot.np=50, obs=x, distr="gbeta", plot.type="contour") 103 | points(f1$estimate["shape1"], f1$estimate["shape0"], pch="+", col="red") 104 | points(2, 2, pch="x", col="green") 105 | 106 | 107 | par(mfrow=c(1,3)) 108 | llcurve(plot.min=0.1, plot.max=5, plot.arg="shape0", fix.arg=as.list(f1$estimate[-1]), plot.np=50, 109 | obs=x, distr="gbeta", enhance=FALSE) 110 | abline(v=c(2, f1$estimate["shape0"]), col=c("green", "red")) 111 | llcurve(plot.min=0.1, plot.max=4, plot.arg="shape1", fix.arg=as.list(f1$estimate[-2]), plot.np=50, 112 | obs=x, distr="gbeta", enhance=FALSE) 113 | abline(v=c(2, f1$estimate["shape1"]), col=c("green", "red")) 114 | llcurve(plot.min=0.1, plot.max=4, plot.arg="shape2", fix.arg=as.list(f1$estimate[-3]), plot.np=50, 115 | obs=x, distr="gbeta", enhance=FALSE) 116 | abline(v=c(5/2, f1$estimate["shape2"]), col=c("green", "red")) 117 | 118 | 119 | #bootstrap 120 | b1 <- bootdist(f1, niter=nboot, silent=TRUE) 121 | summary(b1) 122 | 123 | plot(b1, enhance=TRUE, trueval=c(2, 2, 5/2)) 124 | } 125 | 126 | #____________________________________________________________ 127 | #init value 128 | 129 | 130 | 131 | 132 | s00 <- optimize(function(z) 133 | (mbbefd:::Theil.emp(x) - mbbefd:::Theil.theo.shape0(z, obs=x))^2, lower=0.01, upper=20)$minimum 134 | initpar1 <- c(list(shape0=1), as.list(fitdist(x, "beta", method="mme")$estimate)) 135 | initpar2 <- c(list(shape0=s00), as.list(fitdist(x^s00, "beta", method="mme")$estimate)) 136 | 137 | 138 | 139 | 140 | #____________________________________________________________ 141 | 142 | fitdist(x, "gbeta", method="mle", start=initpar1) 143 | fitdist(x, "gbeta", method="mle", start=initpar2) 144 | 145 | f2 <- fitdist(x, "gbeta", method="mle", start=initpar1) 146 | summary(f2) 147 | cdfcomp(f2, do.points=FALSE, ylogscale = TRUE) 148 | lines(0:100/100, pgbeta(0:100/100, 2, 2, 5/2), col="green") 149 | -------------------------------------------------------------------------------- /man/fitDR.Rd: -------------------------------------------------------------------------------- 1 | \name{fitDR} 2 | \alias{fitDR} 3 | \title{Fit of destruction rate models} 4 | 5 | \description{ 6 | Fit of univariate distributions to destruction rate data by maximum likelihood (mle), 7 | moment matching (mme), quantile matching (qme) or 8 | maximizing goodness-of-fit estimation (mge). 9 | The latter is also known as minimizing distance estimation. 10 | Generic methods are \code{print}, \code{plot}, 11 | \code{summary}, \code{quantile}, \code{logLik}, \code{vcov} and \code{coef}. 12 | } 13 | 14 | \usage{ 15 | fitDR(x, dist, method="mle", start=NULL, optim.method="default", \dots) 16 | 17 | } 18 | 19 | \arguments{ 20 | \item{x}{A numeric vector.} 21 | \item{dist}{A character string \code{"name"} naming a distribution among 22 | \code{"oiunif"}, \code{"oistpareto"}, \code{"oibeta"}, \code{"oigbeta"}, 23 | \code{"mbbefd"}, \code{"MBBEFD"}.} 24 | \item{method}{A character string coding for the fitting method: 25 | \code{"mle"} for 'maximum likelihood estimation', 26 | \code{"tlmme"} for 'total-loss-moment matching estimation'.} 27 | \item{start}{A named list giving the initial values of parameters 28 | of the named distribution 29 | or a function of data computing initial values and returning a named list. 30 | This argument may be omitted (default) for some distributions for which reasonable 31 | starting values are computed (see the 'details' section of 32 | \code{\link[fitdistrplus]{mledist}}).} 33 | \item{optim.method}{\code{"default"} or an optimization method to pass to \code{\link{optim}}.} 34 | 35 | \item{\dots}{Further arguments to be passed to \code{"fitdist"} 36 | when \code{method != "tlmme"}. 37 | See \code{\link[fitdistrplus]{fitdist}} for details on parameter estimation.} 38 | } 39 | 40 | \details{ 41 | 42 | The fitted distribution (\code{dist}) has its d, p, q, r functions defined in the 43 | man page: \code{\link{oiunif}}, \code{\link{oistpareto}}, \code{\link{oibeta}}, 44 | \code{\link{oigbeta}}, \code{\link{mbbefd}}, \code{\link{MBBEFD}}. 45 | 46 | The two possible fitting methods are described below: 47 | \describe{ 48 | \item{When \code{method="mle"}}{ 49 | Maximum likelihood estimation consists in maximizing the log-likelihood. 50 | A numerical optimization is carried out in \code{\link[fitdistrplus]{mledist}} via \code{optim} 51 | to find the best values (see \code{\link[fitdistrplus]{mledist}} for details). 52 | For one-inflated distributions, the probability parameter is estimated 53 | by a closed-form formula and other parameters use a two-optimization procedures. 54 | } 55 | \item{When \code{method="tlmme"}}{ 56 | Total loss and moment matching estimation consists in equalizing theoretical and empirical 57 | total loss as well as theoretical and empirical moments. 58 | The theoretical and the empirical moments are matched numerically, 59 | by minimization of the sum of squared differences between observed and theoretical 60 | quantities (see \code{\link[fitdistrplus]{mmedist}} for details). 61 | } 62 | 63 | } 64 | 65 | For one-inflated distributions, 66 | by default, direct optimization of the log-likelihood (or other criteria depending 67 | of the chosen method) is performed using \code{\link{optim}}, 68 | with the "L-BFGS-B" method for distributions characterized by more than 69 | one parameter and the "Brent" method for distributions characterized by only 70 | one parameter. Note that when errors are raised by \code{optim}, it's a good 71 | idea to start by adding traces during the optimization process by adding 72 | \code{control=list(trace=1, REPORT=1)}. 73 | For the MBBEFD distribution, \code{\link[alabama]{constrOptim.nl}} is used. 74 | 75 | A pre-fitting process is carried out for the following distributions 76 | \code{"mbbefd"}, \code{"MBBEFD"} and \code{"oigbeta"} before 77 | the main optimization. 78 | 79 | The estimation process is carried out via \code{fitdist} from the 80 | \code{fitdistrplus} package and the output object will inherit from the 81 | \code{"fitdist"} class. 82 | Therefore, the following generic methods are available \code{print}, \code{plot}, 83 | \code{summary}, \code{quantile}, \code{logLik}, \code{vcov} and \code{coef}. 84 | 85 | 86 | } 87 | 88 | \value{ 89 | \code{fitDR} returns an object of class \code{"fitDR"} inheriting 90 | from the \code{"fitdist"} class. That is a list with the following components: 91 | \item{estimate }{ the parameter estimates.} 92 | \item{method }{ the character string coding for the fitting method : 93 | \code{"mle"} for 'maximum likelihood estimation', \code{"tlmme"} for 'matching total loss moment estimation'.} 94 | \item{sd}{ the estimated standard errors, \code{NA} if numerically not computable 95 | or \code{NULL} if not available.} 96 | \item{cor}{ the estimated correlation matrix, \code{NA} if numerically not computable 97 | or \code{NULL} if not available.} 98 | \item{vcov}{ the estimated variance-covariance matrix, \code{NULL} if not available.} 99 | \item{loglik}{ the log-likelihood.} 100 | \item{aic}{ the Akaike information criterion.} 101 | \item{bic}{ the the so-called BIC or SBC (Schwarz Bayesian criterion).} 102 | \item{n}{ the length of the data set.} 103 | \item{data}{ the data set.} 104 | \item{distname}{ the name of the distribution.} 105 | \item{fix.arg}{ the named list giving the values of parameters of the named distribution 106 | that must be kept fixed rather than estimated by maximum likelihood or \code{NULL} 107 | if there are no such parameters. } 108 | \item{fix.arg.fun}{the function used to set the value of \code{fix.arg} or \code{NULL}.} 109 | \item{discrete}{ the input argument or the automatic definition by the function to be passed 110 | to functions \code{\link[fitdistrplus]{gofstat}}, \code{\link[fitdistrplus]{plotdist}} 111 | and \code{\link[fitdistrplus]{cdfcomp}}. } 112 | \item{dots}{ the list of further arguments passed in \dots to be used in \code{\link[fitdistrplus]{bootdist}} 113 | in iterative calls to \code{\link[fitdistrplus]{mledist}}, \code{\link[fitdistrplus]{mmedist}}, 114 | \code{\link[fitdistrplus]{qmedist}}, \code{\link[fitdistrplus]{mgedist}} or 115 | \code{NULL} if no such arguments.} 116 | \item{weights}{the vector of weigths used in the estimation process or \code{NULL}.} 117 | 118 | Generic functions: 119 | \describe{ 120 | \item{\code{print}}{ 121 | The print of a \code{"fitDR"} object shows few traces about the fitting method and 122 | the fitted distribution. 123 | } 124 | \item{\code{summary}}{ 125 | The summary provides the parameter estimates of the fitted distribution, the log-likelihood, 126 | AIC and BIC statistics and when the maximum likelihood is used, the standard errors of the 127 | parameter estimates and the correlation matrix between parameter estimates. 128 | } 129 | \item{\code{plot}}{ 130 | The plot of an object of class "fitDR" returned by \code{fitdist} uses the function 131 | \code{\link[fitdistrplus]{plotdist}}. An object of class "fitdist" or a list of objects of class 132 | "fitDR" corresponding to various fits using the same data set may also be plotted 133 | using a cdf plot (function \code{\link[fitdistrplus]{cdfcomp}}), 134 | a density plot(function \code{\link[fitdistrplus]{denscomp}}), 135 | a density Q-Q plot (function \code{\link[fitdistrplus]{qqcomp}}), 136 | or a P-P plot (function \code{\link[fitdistrplus]{ppcomp}}). 137 | } 138 | \item{\code{logLik}}{ Extracts the estimated log-likelihood from the \code{"fitDR"} object. 139 | } 140 | \item{\code{vcov}}{ Extracts the estimated var-covariance matrix from the 141 | \code{"fitDR"} object (only available when \code{method = "mle"}). 142 | } 143 | \item{\code{coef}}{ Extracts the fitted coefficients from the \code{"fitDR"} object. 144 | } 145 | } 146 | 147 | } 148 | 149 | \seealso{ 150 | See \code{\link[fitdistrplus:mledist]{mledist}}, \code{\link[fitdistrplus:mmedist]{mmedist}}, 151 | for details on parameter estimation. 152 | See \code{\link[fitdistrplus:gofstat]{gofstat}} for goodness-of-fit statistics. 153 | See \code{\link[fitdistrplus:plotdist]{plotdist}}, 154 | \code{\link[fitdistrplus:graphcomp]{graphcomp}} for graphs. 155 | See \code{\link{bootDR}} for bootstrap procedures 156 | See \code{\link{optim}} for base R optimization procedures. 157 | See \code{\link[fitdistrplus:quantile]{quantile.fitdist}}, another generic function, which calculates 158 | quantiles from the fitted distribution. 159 | See \code{\link{quantile}} for base R quantile computation. 160 | } 161 | 162 | \references{ 163 | Cullen AC and Frey HC (1999), \emph{Probabilistic techniques in exposure assessment}. 164 | Plenum Press, USA, pp. 81-155. 165 | 166 | Venables WN and Ripley BD (2002), \emph{Modern applied statistics with S}. 167 | Springer, New York, pp. 435-446. 168 | 169 | Vose D (2000), \emph{Risk analysis, a quantitative guide}. 170 | John Wiley & Sons Ltd, Chischester, England, pp. 99-143. 171 | 172 | Delignette-Muller ML and Dutang C (2015), 173 | \emph{fitdistrplus: An R Package for Fitting Distributions}. 174 | Journal of Statistical Software, 64(4), 1-34. 175 | 176 | } 177 | 178 | 179 | \author{ 180 | Christophe Dutang. 181 | } 182 | 183 | \examples{ 184 | 185 | # (1) fit of a one-inflated beta distribution by maximum likelihood estimation 186 | # 187 | n <- 1e3 188 | set.seed(12345) 189 | x <- roibeta(n, 3, 2, 1/6) 190 | 191 | f1 <- fitDR(x, "oibeta", method="mle") 192 | summary(f1) 193 | 194 | plot(bootdist(f1, niter=11), enhance=TRUE, trueval=c(3, 2, 1/6)) 195 | 196 | } 197 | \keyword{distribution} 198 | -------------------------------------------------------------------------------- /R/distr-mbbefdR-1stparam.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | ### R version of d,p,q,r functions MBBEFD(a,b) 4 | #see r functions in distr-mbbefdCpp.R 5 | 6 | dmbbefdR <- function(x, a, b, log=FALSE) 7 | { 8 | #sanity check 9 | stopifnot(is.numeric(x)) 10 | stopifnot(is.numeric(a)) 11 | stopifnot(is.numeric(b)) 12 | 13 | if(min(length(a), length(b), length(x)) <= 0) 14 | return(numeric(0)) 15 | m <- max(length(a), length(b), length(x)) 16 | a <- rep_len(a, length.out=m) 17 | b <- rep_len(b, length.out=m) 18 | x <- rep_len(x, length.out=m) 19 | 20 | #default to NaN: b=+infty; a=+infy && b > 0 && b < 1; 21 | #a != -1 && a +1 >0 && b > 0 && a*(1-b) >= 0 22 | res <- rep(NaN, m) 23 | id1 <- x == 1 24 | id01 <- 0 < x & x < 1 25 | 26 | #unit indicator - 27 | idDirac <- (b == 0 & a > 0) | (a == -1 & b > 1) 28 | res[idDirac] <- 1 * id1[idDirac] #x == 1 29 | 30 | #identity function 31 | ididentity <- (b == 1 & a > -1) | (b == Inf & a >-1 & a < 0) | (a == 0 & b > 0) 32 | res[ididentity] <- 1 * id1[ididentity] #x == 1 33 | 34 | #b only 35 | idbonly <- a == Inf & b > 0 & b < 1 36 | res[idbonly] <- 0 #0 37 | idbonly <- a == Inf & b > 0 & b < 1 & is.finite(b) & id01 38 | res[idbonly] <- -log(b[idbonly]) * b[idbonly]^x[idbonly] #-log(b)b^x, x!=1 39 | idbonly <- a == Inf & b > 0 & b < 1 & is.finite(b) & id1 40 | res[idbonly] <- 1 - b[idbonly] #1-b, x==1 41 | 42 | 43 | #main case 44 | idmain <- ((-1 < a & a < 0 & b > 1) | (0 < a & 0 < b & b < 1)) & is.finite(a) & is.finite(b) 45 | res[idmain] <- 0 46 | idmain <- idmain & id01 47 | #- \ln(b) \frac{a(a+1) b^x }{(a+b^x)^2} 48 | res[idmain] <- -a[idmain] * (a[idmain]+1) * b[idmain]^x[idmain] * log(b[idmain]) / (a[idmain] + b[idmain]^x[idmain])^2 49 | idmain <- ((-1 < a & a < 0 & b > 1) | (0 < a & 0 < b & b < 1)) & is.finite(a) & is.finite(b) 50 | idmain <- idmain & id1 51 | #\frac{(a+1)b}{a+b} 52 | res[idmain] <- (a[idmain]+1) * b[idmain] / (a[idmain]+b[idmain]) 53 | 54 | if(log) 55 | res <- log(res) 56 | 57 | res 58 | } 59 | 60 | pmbbefdR <- function(q, a, b, lower.tail = TRUE, log.p = FALSE) 61 | { 62 | #sanity check 63 | stopifnot(is.numeric(q)) 64 | stopifnot(is.numeric(a)) 65 | stopifnot(is.numeric(b)) 66 | 67 | if(min(length(a), length(b), length(q)) <= 0) 68 | return(numeric(0)) 69 | m <- max(length(a), length(b), length(q)) 70 | a <- rep_len(a, length.out=m) 71 | b <- rep_len(b, length.out=m) 72 | q <- rep_len(q, length.out=m) 73 | 74 | #default to NaN: b=+infty; a=+infy && b > 0 && b < 1; 75 | #a != -1 && a +1 >0 && b > 0 && a*(1-b) >= 0 76 | res <- rep(NaN, m) 77 | id0 <- 0 < q 78 | id1 <- q < 1 79 | 80 | #unit indicator - 81 | idDirac <- (b == 0 & a > 0) | (a == -1 & b > 1) 82 | res[idDirac] <- 1*(q[idDirac] >= 1) 83 | 84 | #identity function 85 | ididentity <- (b == 1 & a > -1) | (b == Inf & a >-1 & a < 0) | (a == 0 & b > 0) 86 | res[ididentity] <- 1 * (q[ididentity] >= 1) 87 | 88 | #b only 89 | idbonly <- a == Inf & b > 0 & b < 1 & is.finite(b) 90 | res[idbonly] <- 1*(q[idbonly] >= 1) # 1_(x >= 1) 91 | idbonly <- a == Inf & b > 0 & b < 1 & is.finite(b) & id0 & id1 92 | res[idbonly] <- 1-b[idbonly]^q[idbonly] 93 | 94 | #main case 95 | idmain <- ((-1 < a & a < 0 & b > 1) | (0 < a & 0 < b & b < 1)) & is.finite(a) & is.finite(b) 96 | res[idmain] <- 1*(q[idmain] >= 1) # 1_(x >= 1) 97 | idmain <- idmain & id0 & id1 98 | res[idmain] <- 1 - (a[idmain]+1)*b[idmain]^q[idmain]/(a[idmain]+b[idmain]^q[idmain]) 99 | 100 | if(!lower.tail) 101 | res <- 1-res 102 | if(log.p) 103 | res <- log(res) 104 | 105 | res 106 | } 107 | 108 | 109 | qmbbefdR <- function(p, a, b, lower.tail = TRUE, log.p = FALSE) 110 | { 111 | #sanity check 112 | stopifnot(is.numeric(p)) 113 | stopifnot(is.numeric(a)) 114 | stopifnot(is.numeric(b)) 115 | 116 | if(min(length(a), length(b), length(p)) <= 0) 117 | return(numeric(0)) 118 | m <- max(length(a), length(b), length(p)) 119 | a <- rep_len(a, length.out=m) 120 | b <- rep_len(b, length.out=m) 121 | p <- rep_len(p, length.out=m) 122 | 123 | if(!lower.tail) 124 | p <- 1-p 125 | if(log.p) 126 | p <- exp(p) 127 | 128 | #default to NaN: b=+infty; a=+infy && b > 0 && b < 1; 129 | #a != -1 && a +1 >0 && b > 0 && a*(1-b) >= 0 130 | res <- rep(NaN, m) 131 | 132 | #unit indicator - 133 | idDirac <- (b == 0 & a > 0) | (a == -1 & b > 1) 134 | idDirac <- idDirac & 0 <= p & p <= 1 135 | res[idDirac] <- 1 136 | 137 | #identity function 138 | ididentity <- (b == 1 & a > -1) | (b == Inf & a >-1 & a < 0) | (a == 0 & b > 0) 139 | ididentity <- ididentity & 0 <= p & p <= 1 140 | res[ididentity] <- 1 141 | 142 | #b only 143 | idbonly <- a == Inf & b > 0 & b < 1 & is.finite(b) & 0 <= p & p < 1-b 144 | res[idbonly] <- log(1 - p[idbonly]) / log(b[idbonly]) #log(1-p)/log(b) 145 | idbonly <- a == Inf & b > 0 & b < 1 & is.finite(b) & p >= 1-b & p <= 1 146 | res[idbonly] <- 1 #1 147 | 148 | #main case 149 | idmain <- ((-1 < a & a < 0 & b > 1) | (0 < a & 0 < b & b < 1)) & is.finite(a) & is.finite(b) 150 | idmain <- idmain & 0 == p 151 | res[idmain] <- 0 #0 152 | idmain <- ((-1 < a & a < 0 & b > 1) | (0 < a & 0 < b & b < 1)) & is.finite(a) & is.finite(b) 153 | idmain <- idmain & 0 < p & p < 1 - (a+1)*b/(a+b) 154 | #\frac{\ln\left(\frac{(1-p)a}{a+p}\right)}{\ln(b)} 155 | res[idmain] <- log( (1 - p[idmain]) * a[idmain] / (a[idmain] + p[idmain]) ) / log( b[idmain] ) 156 | idmain <- ((-1 < a & a < 0 & b > 1) | (0 < a & 0 < b & b < 1)) & is.finite(a) & is.finite(b) 157 | idmain <- idmain & p >= 1 - (a+1)*b/(a+b) & p <= 1 158 | res[idmain] <- 1 #1 159 | 160 | res 161 | } 162 | 163 | 164 | rmbbefdR <- function(n, a, b) 165 | { 166 | #sanity check 167 | stopifnot(is.numeric(n)) 168 | stopifnot(is.numeric(a)) 169 | stopifnot(is.numeric(b)) 170 | if(length(n) > 1) 171 | n <- length(n) 172 | 173 | if(min(length(a), length(b), n) <= 0) 174 | return(numeric(0)) 175 | m <- max(length(a), length(b), n) 176 | a <- rep_len(a, length.out=m) 177 | b <- rep_len(b, length.out=m) 178 | 179 | #default to NaN: b=+infty; a=+infy && b > 0 && b < 1; 180 | #a != -1 && a +1 >0 && b > 0 && a*(1-b) >= 0 181 | res <- rep(NaN, m) 182 | 183 | #unit indicator - 184 | idDirac <- (b == 0 & a > 0) | (a == -1 & b > 1) 185 | res[idDirac] <- 1 186 | 187 | #identity function 188 | ididentity <- (b == 1 & a > -1) | (b == Inf & a >-1 & a < 0) | (a == 0 & b > 0) 189 | res[ididentity] <- 1 190 | 191 | #b only 192 | idbonly <- a == Inf & b > 0 & b < 1 & is.finite(b) 193 | if(sum(idbonly) > 0) 194 | res[idbonly] <- qmbbefdR(runif(sum(idbonly)), a[idbonly], b[idbonly]) 195 | 196 | #main case 197 | idmain <- ((-1 < a & a < 0 & b > 1) | (0 < a & 0 < b & b < 1)) & is.finite(b) 198 | if(sum(idmain) > 0) 199 | res[idmain] <- qmbbefdR(runif(sum(idmain)), a[idmain], b[idmain]) 200 | 201 | res 202 | } 203 | 204 | 205 | ecmbbefdR <- function(x, a, b) 206 | { 207 | #sanity check 208 | stopifnot(is.numeric(x)) 209 | stopifnot(is.numeric(a)) 210 | stopifnot(is.numeric(b)) 211 | 212 | if(min(length(a), length(b), length(x)) <= 0) 213 | return(numeric(0)) 214 | m <- max(length(a), length(b), length(x)) 215 | a <- rep_len(a, length.out=m) 216 | b <- rep_len(b, length.out=m) 217 | x <- rep_len(x, length.out=m) 218 | 219 | #default to NaN: b=+infty; a=+infy && b > 0 && b < 1; 220 | #a != -1 && a +1 >0 && b > 0 && a*(1-b) >= 0 221 | res <- rep(NaN, m) 222 | id0 <- 0 <= x 223 | id1 <- x <= 1 224 | 225 | #unit indicator - 226 | idDirac <- (b == 0 & a > 0) | (a == -1 & b > 1) 227 | idDirac <- idDirac & id0 & id1 228 | res[idDirac] <- 1*(x[idDirac] == 1) 229 | 230 | #identity function 231 | ididentity <- (b == 1 & a > -1) | (b == Inf & a >-1 & a < 0) | (a == 0 & b > 0) 232 | ididentity <- ididentity & x > 0 & id1 233 | res[ididentity] <- x[ididentity] 234 | 235 | #b only 236 | idbonly <- a == Inf & b > 0 & b < 1 & is.finite(b) & id0 & id1 237 | res[idbonly] <- (1-b[idbonly]^x[idbonly])/(1-b[idbonly]) 238 | 239 | #main case 240 | idmain <- ((-1 < a & a < 0 & b > 1) | (0 < a & 0 < b & b < 1)) & is.finite(a) & is.finite(b) 241 | idmain <- idmain & id0 & id1 242 | res[idmain] <- log((a[idmain]+b[idmain]^x[idmain])/(a[idmain]+1)) / log((a[idmain]+b[idmain])/(a[idmain]+1)) 243 | 244 | res 245 | } 246 | 247 | #moment 248 | mmbbefdR <- function(order, a, b) 249 | { 250 | #sanity check 251 | stopifnot(is.numeric(order)) 252 | stopifnot(is.numeric(a)) 253 | stopifnot(is.numeric(b)) 254 | 255 | if(min(length(a), length(b), length(order)) <= 0) 256 | return(numeric(0)) 257 | m <- max(length(a), length(b), length(order)) 258 | a <- rep_len(a, length.out=m) 259 | b <- rep_len(b, length.out=m) 260 | order <- rep_len(order, length.out=m) 261 | 262 | res <- rep(NaN, m) 263 | 264 | #unit indicator - 265 | idDirac <- (b == 0 & a > 0) | (a == -1 & b > 1) 266 | res[idDirac] <- 1^order[idDirac] 267 | 268 | #identity function 269 | ididentity <- (b == 1 & a > -1) | (b == Inf & a >-1 & a < 0) | (a == 0 & b > 0) 270 | res[ididentity] <- 1^order[ididentity] 271 | 272 | #b only 273 | idbonly <- a == Inf & b > 0 & b < 1 & is.finite(b) & order == 1 274 | res[idbonly] <- (b[idbonly] - 1) / log(b[idbonly]) 275 | idbonly <- a == Inf & b > 0 & b < 1 & is.finite(b) & order != 1 276 | if(sum(idbonly) > 0) 277 | { 278 | surv1 <- function(x, b, k) 279 | b^(x^(1/k)) 280 | mom1 <- function(b, k) 281 | { 282 | res <- try(integrate(surv1, b, k, lower=0, upper = 1)) 283 | if(inherits(res, "try-error")) 284 | return(NaN) 285 | res$value 286 | } 287 | res[idbonly] <- sapply(1:sum(idbonly), function(i) 288 | mom1(k=order[idbonly][i], b=b[idbonly][i])) 289 | } 290 | #main case 291 | idmain <- (-1 < a & a < 0 & b > 1) | (0 < a & 0 < b & b < 1) 292 | idmain <- idmain & is.finite(a) & is.finite(b) & order == 1 293 | res[idmain] <- log( (a[idmain]+b[idmain]) / (a[idmain]+1) ) / log(b[idmain]) * (a[idmain]+1) 294 | idmain <- (-1 < a & a < 0 & b > 1) | (0 < a & 0 < b & b < 1) 295 | idmain <- idmain & is.finite(a) & is.finite(b) & order != 1 296 | if(sum(idmain) > 0) 297 | { 298 | surv2 <- function(x, a, b, k) 299 | (a+1)*b^(x^(1/k))/(a+b^(x^(1/k))) 300 | mom2 <- function(a, b, k) 301 | { 302 | res <- try(integrate(surv2, a, b, k, lower = 0, upper = 1)) 303 | if(inherits(res, "try-error")) 304 | return(NaN) 305 | res$value 306 | } 307 | res[idmain] <- sapply(1:sum(idmain), function(i) 308 | mom2(k=order[idmain][i], a=a[idmain][i], b=b[idmain][i])) 309 | } 310 | 311 | res 312 | } 313 | 314 | #total loss 315 | tlmbbefdR <- function(a, b) 316 | { 317 | #sanity check 318 | stopifnot(is.numeric(a)) 319 | stopifnot(is.numeric(b)) 320 | 321 | if(min(length(a), length(b)) <= 0) 322 | return(numeric(0)) 323 | m <- max(length(a), length(b)) 324 | a <- rep_len(a, length.out=m) 325 | b <- rep_len(b, length.out=m) 326 | 327 | #default to NaN: b=+infty; a=+infy && b > 0 && b < 1; 328 | #a != -1 && a +1 >0 && b > 0 && a*(1-b) >= 0 329 | res <- rep(NaN, m) 330 | 331 | #unit indicator - 332 | idDirac <- (b == 0 & a > 0) | (a == -1 & b > 1) 333 | res[idDirac] <- 1 334 | 335 | #identity function 336 | ididentity <- (b == 1 & a > -1) | (b == Inf & a >-1 & a < 0) | (a == 0 & b > 0) 337 | res[ididentity] <- 1 338 | 339 | #b only 340 | idbonly <- a == Inf & b > 0 & b < 1 & is.finite(b) 341 | res[idbonly] <- b[idbonly] 342 | 343 | #main case 344 | idmain <- ((-1 < a & a < 0 & b > 1) | (0 < a & 0 < b & b < 1)) & is.finite(a) & is.finite(b) 345 | res[idmain] <- (a[idmain] + 1) * b[idmain] / (a[idmain] + b[idmain]) 346 | 347 | res 348 | } 349 | 350 | 351 | 352 | ### d,p,q,ec,m,tl functions MBBEFD(a,b) 353 | 354 | dmbbefd <- dmbbefdR 355 | 356 | pmbbefd <- pmbbefdR 357 | 358 | qmbbefd <- qmbbefdR 359 | 360 | ecmbbefd <- ecmbbefdR 361 | 362 | mmbbefd <- mmbbefdR 363 | 364 | tlmbbefd <- tlmbbefdR 365 | 366 | -------------------------------------------------------------------------------- /vignettes/mbbefd.bib: -------------------------------------------------------------------------------- 1 | %% This BibTeX bibliography file was created using BibDesk. 2 | %% http://bibdesk.sourceforge.net/ 3 | 4 | %% Created for Christophe Dutang at 2015-11-12 17:38:19 +0100 5 | 6 | 7 | %% Saved with string encoding Unicode (UTF-8) 8 | 9 | 10 | 11 | @article{abanetal06, 12 | Author = {A.B. Aban and M.M. Meerschaert and A.K. Panorska}, 13 | Date-Added = {2015-11-12 16:37:45 +0000}, 14 | Date-Modified = {2015-11-12 16:37:45 +0000}, 15 | Journal = {Journal of the American Statistical Association}, 16 | Title = {{Paramter estimation for the truncated Pareto distribution}}, 17 | Year = {2006}} 18 | 19 | @incollection{arnold08, 20 | Author = {Barry C. Arnold}, 21 | Booktitle = {Encyclopedia of Statistical Sciences}, 22 | Date-Added = {2015-11-12 16:37:45 +0000}, 23 | Date-Modified = {2015-11-12 16:37:45 +0000}, 24 | Publisher = {Wiley Interscience}, 25 | Title = {Pareto Distributions}, 26 | Year = {2008}} 27 | 28 | @book{arnold83, 29 | Author = {Barry C. Arnold}, 30 | Date-Added = {2015-11-12 16:37:45 +0000}, 31 | Date-Modified = {2015-11-12 16:37:45 +0000}, 32 | Publisher = {International Co-operative Publishing House}, 33 | Title = {Pareto Distributions}, 34 | Year = {1983}} 35 | 36 | @article{aryalnadarajah04, 37 | Author = {G. Aryal and S. Nadarajah}, 38 | Date-Added = {2015-11-12 16:37:45 +0000}, 39 | Date-Modified = {2015-11-12 16:37:45 +0000}, 40 | Journal = {Serdica Mathematical Journal}, 41 | Pages = {513-526}, 42 | Title = {Information matrix for beta distributions}, 43 | Volume = {30}, 44 | Year = {2004}} 45 | 46 | @article{brazauskas02, 47 | Author = {V. Brazauskas}, 48 | Date-Added = {2015-11-12 16:37:45 +0000}, 49 | Date-Modified = {2015-11-12 16:37:45 +0000}, 50 | Journal = {Statistics and Probability Letters}, 51 | Pages = {159-167}, 52 | Title = {Fisher information matrix of the {Feller-Pareto} distribution}, 53 | Volume = {59}, 54 | Year = {2002}} 55 | 56 | @article{cao2008convexities, 57 | Author = {Cao, Jian and Niu, Da-Wei and Qi, Feng}, 58 | Date-Added = {2015-11-12 16:37:45 +0000}, 59 | Date-Modified = {2015-11-12 16:37:45 +0000}, 60 | Journal = {Applied Mathematics E-Notes}, 61 | Pages = {53-57}, 62 | Title = {Convexities of some functions involving the polygamma functions}, 63 | Volume = {8}, 64 | Year = {2008}} 65 | 66 | @book{carterbrunt00, 67 | Author = {M. Carter and B. van Brunt}, 68 | Date-Added = {2015-11-12 16:37:45 +0000}, 69 | Date-Modified = {2015-11-12 16:37:45 +0000}, 70 | Publisher = {Springer}, 71 | Title = {The Lebesgue-Stieltjes Integral: a Practical Introduction}, 72 | Year = {2000}} 73 | 74 | @book{casellalehmann98, 75 | Author = {G. Casella and E.L Lehmann}, 76 | Date-Added = {2015-11-12 16:37:45 +0000}, 77 | Date-Modified = {2015-11-12 16:37:45 +0000}, 78 | Publisher = {Springer-Verlag}, 79 | Title = {Theory of Point Estimation}, 80 | Year = {1998}} 81 | 82 | @techreport{clark13, 83 | Author = {D.R. Clark}, 84 | Date-Added = {2015-11-12 16:37:45 +0000}, 85 | Date-Modified = {2015-11-12 16:37:45 +0000}, 86 | Institution = {Casualty Actuarial Society E-Forum}, 87 | Title = {{A note on the upper-truncated Pareto distribution}}, 88 | Year = {2013}} 89 | 90 | @article{couturier10, 91 | Author = {Couturier, D.-L. and Victoria-Feser, M.-P.}, 92 | Date-Added = {2015-11-12 16:37:45 +0000}, 93 | Date-Modified = {2015-11-12 16:37:45 +0000}, 94 | Journal = {Annals of Applied Statistics, Forthcoming}, 95 | Title = {Zero-inflated truncated generalized Pareto distribution for the analysis of radio audience data}, 96 | Year = {2010}} 97 | 98 | @article{coxwermuth98, 99 | Author = {D. R. Cox}, 100 | Date-Added = {2015-11-12 16:37:45 +0000}, 101 | Date-Modified = {2015-11-12 16:37:45 +0000}, 102 | Journal = {Scandinavian Journal of Statistics}, 103 | Pages = {209-220}, 104 | Title = {Likelihood factorizations for mixed discrete and continuous variables}, 105 | Volume = {26}, 106 | Year = {1998}} 107 | 108 | @unpublished{dtggespedi15:1infl, 109 | Author = {C. Dutang and M. Gesmann and G. Spedicato}, 110 | Date-Added = {2015-11-12 16:37:45 +0000}, 111 | Date-Modified = {2015-11-12 16:37:45 +0000}, 112 | Note = {preprint}, 113 | Title = {Using one-inflated distributions for destruction rate models}, 114 | Year = {2015}} 115 | 116 | @unpublished{dtggespedi15:mbbefd, 117 | Author = {C. Dutang and M. Gesmann and G. Spedicato}, 118 | Date-Added = {2015-11-12 16:37:45 +0000}, 119 | Date-Modified = {2015-11-12 16:37:45 +0000}, 120 | Note = {preprint}, 121 | Title = {Using {MBBEFD} distributions for destruction rate models}, 122 | Year = {2015}} 123 | 124 | @book{hornjohnson90, 125 | Author = {R. A. Horn and C. R. Johnson}, 126 | Date-Added = {2015-11-12 16:37:45 +0000}, 127 | Date-Modified = {2015-11-12 16:37:45 +0000}, 128 | Publisher = {Cambridge University Press}, 129 | Title = {Matrix Analysis}, 130 | Year = {1990}} 131 | 132 | @unpublished{huan98, 133 | Author = {A. Huan}, 134 | Date-Added = {2015-11-12 16:37:45 +0000}, 135 | Date-Modified = {2015-11-12 16:37:45 +0000}, 136 | Note = {tech report}, 137 | Title = {Statistical Mechanics}, 138 | Year = {1998}} 139 | 140 | @book{klugmanetal12, 141 | Author = {S.A. Klugman and H.H. Panjer and G.E. Willmot}, 142 | Date-Added = {2015-11-12 16:37:45 +0000}, 143 | Date-Modified = {2015-11-12 16:37:45 +0000}, 144 | Publisher = {Wiley}, 145 | Title = {Loss Models: From Data to Decisions}, 146 | Year = {2012}} 147 | 148 | @book{kotzetal04, 149 | Date-Added = {2015-11-12 16:37:45 +0000}, 150 | Date-Modified = {2015-11-12 16:37:45 +0000}, 151 | Publisher = {World Scientific}, 152 | Title = {Beyond Beta: Other Continuous Families Distributions with Bounded Support and Applications}, 153 | Year = {2004}} 154 | 155 | @manual{mbbefdpkg, 156 | Author = {Giorgio Spedicato and Christophe Dutang}, 157 | Date-Added = {2015-11-12 16:37:45 +0000}, 158 | Date-Modified = {2015-11-12 16:37:45 +0000}, 159 | Note = {R package version 0.7-1}, 160 | Title = {mbbefd: Maxwell Boltzmann Bose Einstein Fermi Dirac Distribution and Destruction Rate Modelling}, 161 | Url = {http://github.com/spedygiorgio/mbbefd}, 162 | Year = {2015}, 163 | Bdsk-Url-1 = {http://github.com/spedygiorgio/mbbefd}} 164 | 165 | @article{mcdonald84, 166 | Author = {J.B. McDonald}, 167 | Date-Added = {2015-11-12 16:37:45 +0000}, 168 | Date-Modified = {2015-11-12 16:37:45 +0000}, 169 | Journal = {Econometrica}, 170 | Pages = {647-664}, 171 | Title = {Some generalized functions for the size distribution of income}, 172 | Volume = {52}, 173 | Year = {1984}} 174 | 175 | @article{mcdonald95, 176 | Author = {J.B. McDonald and Y.J. Xu}, 177 | Date-Added = {2015-11-12 16:37:45 +0000}, 178 | Date-Modified = {2015-11-12 16:37:45 +0000}, 179 | Journal = {Journal of Econometrics}, 180 | Pages = {133-152}, 181 | Title = {A generalization of the beta distribution with applications}, 182 | Volume = {66}, 183 | Year = {1995}} 184 | 185 | @incollection{mcdonaldransom08, 186 | Author = {J.B. McDonald and M. Ransom}, 187 | Booktitle = {Modeling Income Distributions and Lorenz Curves}, 188 | Date-Added = {2015-11-12 16:37:45 +0000}, 189 | Date-Modified = {2015-11-12 16:37:45 +0000}, 190 | Publisher = {Springer}, 191 | Title = {The Generalized Beta Distribution as a Model for the Distribution of Income: Estimation of Related Measures of Inequality}, 192 | Year = {2008}} 193 | 194 | @phdthesis{mills13, 195 | Author = {E.D. Mills}, 196 | Date-Added = {2015-11-12 16:37:45 +0000}, 197 | Date-Modified = {2015-11-12 16:37:45 +0000}, 198 | School = {Graduate College of The University of Iowa}, 199 | Title = {Adjusting for covariates in zero-inflated gamma and zero-inflated log-normal models for semicontinuous data}, 200 | Year = {2013}} 201 | 202 | @article{ospinaferrari10, 203 | Author = {Ospina, R. and Ferrari, Silvia L.P.}, 204 | Date-Added = {2015-11-12 16:37:45 +0000}, 205 | Date-Modified = {2015-11-12 16:37:45 +0000}, 206 | Journal = {Statistical Papers}, 207 | Number = {1}, 208 | Pages = {111--126}, 209 | Publisher = {Springer}, 210 | Title = {Inflated beta distributions}, 211 | Volume = {51}, 212 | Year = {2010}} 213 | 214 | @article{ospinaferrari12, 215 | Author = {Ospina, R. and Ferrari, Silvia L.P.}, 216 | Date-Added = {2015-11-12 16:37:45 +0000}, 217 | Date-Modified = {2015-11-12 16:37:45 +0000}, 218 | Journal = {Computational Statistics \& Data Analysis}, 219 | Number = {6}, 220 | Pages = {1609--1623}, 221 | Publisher = {Elsevier}, 222 | Title = {A general class of zero-or-one inflated beta regression models}, 223 | Volume = {56}, 224 | Year = {2012}} 225 | 226 | @mastersthesis{poulin12, 227 | Author = {M. Poulin}, 228 | Date-Added = {2015-11-12 16:37:45 +0000}, 229 | Date-Modified = {2015-11-12 16:37:45 +0000}, 230 | School = {Centre d'Etudes Actuarielles}, 231 | Title = {Analyse des Solutions Actuarielles en Tarification des Trait\'es de R\'eassurance Non-propotionnelles Non-Vie}, 232 | Year = {2012}} 233 | 234 | @mastersthesis{saunier05, 235 | Author = {J. Saunier}, 236 | Date-Added = {2015-11-12 16:37:45 +0000}, 237 | Date-Modified = {2015-11-12 16:37:45 +0000}, 238 | School = {ISFA, Universit\'e Claude Bernard Lyon 1}, 239 | Title = {{D\'etermination des courbes d'exposition en fonction du capital assur\'e en branche incendie et risques annexes: Comparaison des distributions MBBEFD et Pareto}}, 240 | Year = {2005}} 241 | 242 | @book{nist10, 243 | Date-Added = {2015-04-29 16:36:31 +0000}, 244 | Date-Modified = {2015-04-29 16:36:31 +0000}, 245 | Editor = {F. W. J. Olver and D. W. Lozier and R. F. Boisvert and C. W. Clark}, 246 | Publisher = {Cambridge University Press}, 247 | Title = {{NIST Handbook of Mathematical Functions}}, 248 | Url = {http://dlmf.nist.gov/}, 249 | Year = {2010}, 250 | Bdsk-Url-1 = {http://dlmf.nist.gov/}} 251 | 252 | @book{kotzjohnsonbalak94v1, 253 | Author = {N. Johnson and S. Kotz and N. Balakrishnan}, 254 | Date-Added = {2015-04-29 16:33:57 +0000}, 255 | Date-Modified = {2015-04-29 16:33:57 +0000}, 256 | Publisher = {Wiley Interscience}, 257 | Title = {Continuous Univariate Distributions}, 258 | Volume = {1}, 259 | Year = {1994}} 260 | 261 | @book{kotzjohnsonbalak94v2, 262 | Author = {N. Johnson and S. Kotz and N. Balakrishnan}, 263 | Date-Added = {2015-04-29 16:33:57 +0000}, 264 | Date-Modified = {2015-04-29 16:33:57 +0000}, 265 | Publisher = {Wiley Interscience}, 266 | Title = {Continuous Univariate Distributions}, 267 | Volume = {2}, 268 | Year = {1994}} 269 | 270 | @techreport{antal03, 271 | Author = {P. Antal}, 272 | Date-Added = {2015-04-29 16:32:35 +0000}, 273 | Date-Modified = {2015-04-29 16:32:35 +0000}, 274 | Institution = {Swiss Re}, 275 | Title = {Quantitative Methods in Reinsurance}, 276 | Year = {2003}} 277 | 278 | @techreport{ExposureRating2004, 279 | Author = {Daniel Guggisberg}, 280 | Institution = {Swiss Re}, 281 | Title = {Exposure Rating}, 282 | Url = {http://media.cgd.swissre.com/documents/pub_exposure_rating_en.pdf}, 283 | Year = {2004}, 284 | Bdsk-Url-1 = {http://media.cgd.swissre.com/documents/pub_exposure_rating_en.pdf}} 285 | 286 | @article{bernegger97, 287 | Author = {S. Bernegger}, 288 | Date-Added = {2015-04-29 16:06:24 +0000}, 289 | Date-Modified = {2015-04-29 16:06:24 +0000}, 290 | Journal = {ASTIN Bulletin}, 291 | Number = {1}, 292 | Pages = {99-111}, 293 | Title = {{The Swiss Re Exposure Curves and the MBBEFD Distribution Class}}, 294 | Url = {http://www.casact.net/library/astin/vol27no1/99.pdf}, 295 | Volume = {27}, 296 | Year = {1997}, 297 | Bdsk-Url-1 = {https://www.casact.org/sites/default/files/database/astin_vol27no1_99.pdf}} 298 | 299 | @article{bernegger1997tile, 300 | Author = {BERNEGGER, STEFAN}, 301 | Journal = {Astin Bulletin}, 302 | Pages = {99}, 303 | Title = {TIlE SWISS RE EXPOSURE CURVES AND THE MBBEFD DISTRIBUTION CLASS}, 304 | Year = {1997}} 305 | 306 | @book{mahler, 307 | Author = {Howard Mahler}, 308 | Editor = {Howard Mahler}, 309 | Title = {Mahler's Guide to Advanced Ratemaking}, 310 | Year = {2014}} 311 | 312 | @article{copulaR, 313 | Author = {{Jun Yan}}, 314 | Journal = {Journal of Statistical Software}, 315 | Number = {4}, 316 | Pages = {1--21}, 317 | Title = {Enjoy the Joy of Copulas: With a Package {copula}}, 318 | Url = {http://www.jstatsoft.org/v21/i04/}, 319 | Volume = {21}, 320 | Year = {2007}, 321 | Bdsk-Url-1 = {http://www.jstatsoft.org/v21/i04/}} 322 | 323 | @manual{fitdistrplusR, 324 | Author = {Marie Laure Delignette-Muller and Regis Pouillot and Jean-Baptiste Denis and Christophe Dutang}, 325 | Date-Modified = {2015-04-29 17:25:30 +0000}, 326 | Note = {R package version 1.0-4}, 327 | Title = {fitdistrplus: Help to Fit of a Parametric Distribution to Non-Censored or Censored Data.}, 328 | Year = {2015}} 329 | 330 | @manual{rSoftware, 331 | Address = {Vienna, Austria}, 332 | Author = {{R Core Team}}, 333 | Organization = {R Foundation for Statistical Computing}, 334 | Title = {R: A Language and Environment for Statistical Computing}, 335 | Url = {http://www.R-project.org/}, 336 | Year = {2014}, 337 | Bdsk-Url-1 = {http://www.R-project.org/}} 338 | 339 | @article{salzmann1963, 340 | Author = {Ruth E. Salzmann}, 341 | Journal = {PCAS}, 342 | Pages = {15 - 26}, 343 | Title = {Rating by Layer of Insurance}, 344 | Url = {https://www.casact.org/pubs/proceed/proceed63/63015.pdf}, 345 | Volume = {L}, 346 | Year = {1963}, 347 | Bdsk-Url-1 = {https://www.casact.org/pubs/proceed/proceed63/63015.pdf}} 348 | -------------------------------------------------------------------------------- /R/distr-mbbefdR-2ndparam.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | ### R version of d,p,q,r functions MBBEFD(g,b) 4 | #see r functions in distr-mbbefdCpp.R 5 | 6 | dMBBEFDR <- function(x, g, b, log=FALSE) 7 | { 8 | #sanity check 9 | stopifnot(is.numeric(x)) 10 | stopifnot(is.numeric(g)) 11 | stopifnot(is.numeric(b)) 12 | 13 | if(min(length(g), length(b), length(x)) <= 0) 14 | return(numeric(0)) 15 | m <- max(length(g), length(b), length(x)) 16 | g <- rep_len(g, length.out=m) 17 | b <- rep_len(b, length.out=m) 18 | x <- rep_len(x, length.out=m) 19 | 20 | #default to NaN 21 | res <- rep(NaN, m) 22 | id1 <- x == 1 23 | id01 <- 0 < x & x < 1 24 | 25 | #unit indicator - 26 | idDirac <- g == Inf & b > 0 & b != 1 & is.finite(b) 27 | res[idDirac] <- 1 * id1[idDirac] #x == 1 28 | 29 | #identity function 30 | ididentity <- (g > 1 & b == 0) | (g > 1 & b == Inf) | (g == 1 & b > 0 & b != 1) 31 | res[ididentity] <- 1 * id1[ididentity] #x == 1 32 | 33 | #b only 34 | idbonly <- g > 1 & b < 1 & b > 0 & b*g == 1 & is.finite(b) 35 | res[idbonly] <- 0 36 | idbonly <- g > 1 & b < 1 & b > 0 & b*g == 1 & is.finite(b) & id01 37 | res[idbonly] <- -log(b[idbonly]) * b[idbonly]^x[idbonly] #-log(b)b^x, x!=1 38 | idbonly <- g > 1 & b != 1 & b > 0 & b*g == 1 & is.finite(b) & id1 39 | res[idbonly] <- 1 - b[idbonly] #1-b, x==1 40 | 41 | #g only 42 | idgonly <- g > 1 & b == 1 43 | res[idgonly] <- 0 44 | idgonly <- g > 1 & b == 1 & is.finite(g) & id01 45 | #(g-1)/(1+(g-1)x)^2 46 | res[idgonly] <- (g[idgonly] - 1) / (1 + (g[idgonly] - 1) * x[idgonly])^2 47 | idgonly <- g > 1 & b == 1 & is.finite(g) & id1 48 | #1/g 49 | res[idgonly] <- 1 / g[idgonly] 50 | 51 | #main case 52 | idmain <- g > 1 & b > 0 & b != 1 & b*g != 1 & is.finite(g) & is.finite(b) 53 | res[idmain] <- 0 54 | idmain <- g > 1 & b > 0 & b != 1 & b*g != 1 & is.finite(g) & is.finite(b) & id01 55 | # - \frac{(1-b)\ln(b)(g-1)b^{1+x} }{ ( (g-1)b+(1-gb)b^x)^2} 56 | res[idmain] <- -(1 - b[idmain])*(g[idmain] - 1)*log(b[idmain]) * b[idmain]^(1 - x[idmain]) 57 | res[idmain] <- res[idmain] / ((g[idmain] - 1)*b[idmain]^(1 - x[idmain]) + 1 - g[idmain]*b[idmain])^2 58 | idmain <- g > 1 & b > 0 & b != 1 & b*g != 1 & is.finite(g) & is.finite(b) & id1 59 | #1/g 60 | res[idmain] <- 1 / g[idmain] 61 | 62 | if(log) 63 | res <- log(res) 64 | res 65 | } 66 | 67 | pMBBEFDR <- function(q, g, b, lower.tail = TRUE, log.p = FALSE) 68 | { 69 | #sanity check 70 | stopifnot(is.numeric(q)) 71 | stopifnot(is.numeric(g)) 72 | stopifnot(is.numeric(b)) 73 | 74 | if(min(length(g), length(b), length(q)) <= 0) 75 | return(numeric(0)) 76 | m <- max(length(g), length(b), length(q)) 77 | g <- rep_len(g, length.out=m) 78 | b <- rep_len(b, length.out=m) 79 | q <- rep_len(q, length.out=m) 80 | 81 | #default to NaN 82 | res <- rep(NaN, m) 83 | id0 <- 0 < q 84 | id1 <- q < 1 85 | 86 | #unit indicator - 87 | idDirac <- g == Inf & b > 0 & b != 1 88 | res[idDirac] <- 1*(q[idDirac] >= 1) # 1_(x >= 1) 89 | 90 | #identity function 91 | ididentity <- (g > 1 & b == 0) | (g > 1 & b == Inf) | (g == 1 & b > 0 & b != 1) 92 | res[ididentity] <- 1*(q[ididentity] >= 1) # 1_(x >= 1) 93 | 94 | #b only 95 | idbonly <- g > 1 & b < 1 & b > 0 & b*g == 1 & is.finite(b) 96 | res[idbonly] <- 1*(q[idbonly] >= 1) # 1_(x >= 1) 97 | idbonly <- g > 1 & b < 1 & b > 0 & b*g == 1 & is.finite(b) & id0 & id1 98 | res[idbonly] <- 1 - b[idbonly]^q[idbonly] #1-b^x 99 | 100 | #g only 101 | idgonly <- g > 1 & b == 1 & is.finite(g) 102 | res[idgonly] <- 1*(q[idgonly] >= 1) # 1_(x >= 1) 103 | idgonly <- g > 1 & b == 1 & is.finite(g) & id0 & id1 104 | #1-1/(1+(g-1)x) 105 | res[idgonly] <- 1 - 1 / (1 + (g[idgonly] - 1) * q[idgonly]) 106 | 107 | #main case 108 | idmain <- g > 1 & b > 0 & b != 1 & b*g != 1 & is.finite(g) & is.finite(b) 109 | res[idmain] <- 1*(q[idmain] >= 1) # 1_(x >= 1) 110 | idmain <- g > 1 & b > 0 & b != 1 & b*g != 1 & is.finite(g) & is.finite(b) & id0 & id1 111 | #1-(1-b)/((g-1)b^(1-x) + 1-gb) 112 | res[idmain] <- 1-(1-b[idmain])/((g[idmain]-1)*b[idmain]^(1-q[idmain]) + 1-g[idmain]*b[idmain]) 113 | 114 | if(!lower.tail) 115 | res <- 1-res 116 | if(log.p) 117 | res <- log(res) 118 | 119 | res 120 | } 121 | 122 | 123 | qMBBEFDR <- function(p, g, b, lower.tail = TRUE, log.p = FALSE) 124 | { 125 | #sanity check 126 | stopifnot(is.numeric(p)) 127 | stopifnot(is.numeric(g)) 128 | stopifnot(is.numeric(b)) 129 | 130 | if(min(length(g), length(b), length(p)) <= 0) 131 | return(numeric(0)) 132 | m <- max(length(g), length(b), length(p)) 133 | g <- rep_len(g, length.out=m) 134 | b <- rep_len(b, length.out=m) 135 | p <- rep_len(p, length.out=m) 136 | 137 | #default to NaN 138 | res <- rep(NaN, m) 139 | 140 | if(!lower.tail) 141 | p <- 1-p 142 | if(log.p) 143 | p <- exp(p) 144 | 145 | #unit indicator - 146 | idDirac <- g == Inf & b > 0 & b != 1 147 | idDirac <- idDirac & 0 <= p & p <= 1 148 | res[idDirac] <- 1 149 | 150 | #identity function 151 | ididentity <- (g > 1 & b == 0) | (g > 1 & b == Inf) | (g == 1 & b > 0 & b != 1) 152 | ididentity <- ididentity & 0 <= p & p <= 1 153 | res[ididentity] <- 1 154 | 155 | #b only 156 | idbonly <- g > 1 & b < 1 & b > 0 & b*g == 1 & is.finite(b) & 0 <= p & p < 1-b 157 | res[idbonly] <- log(1 - p[idbonly]) / log(b[idbonly]) #log(1-p)/log(b) 158 | idbonly <- g > 1 & b < 1 & b > 0 & b*g == 1 & is.finite(b) & p >= 1-b & p <= 1 159 | res[idbonly] <- 1 #1 160 | 161 | #g only 162 | idgonly <- g > 1 & b == 1 & is.finite(g) & 0 <= p & p < 1-1/g 163 | res[idgonly] <- p[idgonly] / (1 - p[idgonly]) / (g[idgonly] - 1) #p/(1-p)/(g-1) 164 | idgonly <- g > 1 & b == 1 & is.finite(g) & p >= 1-1/g & p <= 1 165 | res[idgonly] <- 1 #1 166 | 167 | #main case 168 | idmain <- g > 1 & b > 0 & b != 1 & b*g != 1 & is.finite(g) & is.finite(b) & 0 == p 169 | #0 170 | res[idmain] <- 0 171 | idmain <- g > 1 & b > 0 & b != 1 & b*g != 1 & is.finite(g) & is.finite(b) & 0 < p & p < 1-1/g 172 | #(gb-1)/(g-1) + (1-b)/(1-p)/(g-1) 173 | res[idmain] <- (g[idmain]*b[idmain] - 1) / (g[idmain]-1) + (1-b[idmain]) / (1-p[idmain]) / (g[idmain]-1) 174 | #1-log(.)/log(b) 175 | res[idmain] <- 1 - log(res[idmain]) / log(b[idmain]) 176 | idmain <- g > 1 & b > 0 & b != 1 & b*g != 1 & is.finite(g) & is.finite(b) & p >= 1-1/g & p <= 1 177 | res[idmain] <- 1 #1 178 | 179 | res 180 | } 181 | 182 | 183 | rMBBEFDR <- function(n, g, b) 184 | { 185 | #sanity check 186 | stopifnot(is.numeric(n)) 187 | stopifnot(is.numeric(g)) 188 | stopifnot(is.numeric(b)) 189 | if(length(n) > 1) 190 | n <- length(n) 191 | 192 | if(min(length(g), length(b), n) <= 0) 193 | return(numeric(0)) 194 | m <- max(length(g), length(b), n) 195 | g <- rep_len(g, length.out=m) 196 | b <- rep_len(b, length.out=m) 197 | 198 | #default 199 | res <- rep(NaN, m) 200 | 201 | #unit indicator - 202 | idDirac <- g == Inf & b > 0 & b != 1 203 | res[idDirac] <- 1 204 | 205 | #identity function 206 | ididentity <- (g > 1 & b == 0) | (g > 1 & b == Inf) | (g == 1 & b > 0 & b != 1) 207 | res[ididentity] <- 1 208 | 209 | #b only 210 | idbonly <- g > 1 & b < 1 & b > 0 & b*g == 1 & is.finite(b) 211 | if(sum(idbonly) > 0) 212 | res[idbonly] <- qMBBEFDR(runif(sum(idbonly)), g[idbonly], b[idbonly]) 213 | 214 | #g only 215 | idgonly <- g > 1 & b == 1 & is.finite(g) 216 | if(sum(idgonly) > 0) 217 | res[idgonly] <- qMBBEFDR(runif(sum(idgonly)), g[idgonly], b[idgonly]) 218 | 219 | #main case 220 | idmain <- g > 1 & b > 0 & b != 1 & b*g != 1 & is.finite(g) & is.finite(b) 221 | if(sum(idmain) > 0) 222 | res[idmain] <- qMBBEFDR(runif(sum(idmain)), g[idmain], b[idmain]) 223 | 224 | res 225 | } 226 | 227 | 228 | ecMBBEFDR <- function(x, g, b) 229 | { 230 | #sanity check 231 | stopifnot(is.numeric(x)) 232 | stopifnot(is.numeric(g)) 233 | stopifnot(is.numeric(b)) 234 | 235 | if(min(length(g), length(b), length(x)) <= 0) 236 | return(numeric(0)) 237 | m <- max(length(g), length(b), length(x)) 238 | g <- rep_len(g, length.out=m) 239 | b <- rep_len(b, length.out=m) 240 | x <- rep_len(x, length.out=m) 241 | 242 | #default to NaN 243 | res <- rep(NaN, m) 244 | id0 <- 0 <= x 245 | id1 <- x <= 1 246 | 247 | #unit indicator - 248 | idDirac <- g == Inf & b > 0 & b != 1 & id0 & id1 249 | res[idDirac] <- 1*(x[idDirac] > 0) # 1_(0 < x < 1) 250 | 251 | #identity function 252 | ididentity <- (g > 1 & b == 0) | (g > 1 & b == Inf) | (g == 1 & b > 0 & b != 1) 253 | ididentity <- ididentity & id0 & id1 254 | res[ididentity] <- x[ididentity] #x 255 | 256 | #b only 257 | idbonly <- g > 1 & b < 1 & b > 0 & b*g == 1 & is.finite(b) & id0 & id1 258 | res[idbonly] <- (1-b[idbonly]^x[idbonly]) / (1-b[idbonly]) #(1-b^x)/(1-b) 259 | 260 | #g only 261 | idgonly <- g > 1 & b == 1 & is.finite(g) & id0 & id1 262 | #log(1+(g-1)x)/log(g) 263 | res[idgonly] <- log(1+(g[idgonly]-1)*x[idgonly])/log(g[idgonly]) 264 | 265 | #main case 266 | idmain <- g > 1 & b > 0 & b != 1 & b*g != 1 & is.finite(g) & is.finite(b) & id0 & id1 267 | #(g-1)b+(1-gb)b^x 268 | res[idmain] <- (g[idmain]-1)*b[idmain] + (1-g[idmain]*b[idmain])*b[idmain]^x[idmain] 269 | #log(./(1-b))/log(gb) 270 | res[idmain] <- log(res[idmain] / (1-b[idmain])) / log(g[idmain] * b[idmain]) 271 | 272 | res 273 | } 274 | 275 | #moment 276 | mMBBEFDR <- function(order, g, b) 277 | { 278 | #sanity check 279 | stopifnot(is.numeric(order)) 280 | stopifnot(is.numeric(g)) 281 | stopifnot(is.numeric(b)) 282 | 283 | if(min(length(g), length(b), length(order)) <= 0) 284 | return(numeric(0)) 285 | m <- max(length(g), length(b), length(order)) 286 | g <- rep_len(g, length.out=m) 287 | b <- rep_len(b, length.out=m) 288 | order <- rep_len(order, length.out=m) 289 | 290 | res <- rep(NaN, m) 291 | 292 | #unit indicator - 293 | idDirac <- g == Inf & b > 0 & b != 1 294 | res[idDirac] <- 1^order[idDirac] 295 | 296 | #identity function 297 | ididentity <- (g > 1 & b == 0) | (g > 1 & b == Inf) | (g == 1 & b > 0 & b != 1) 298 | res[ididentity] <- 1^order[ididentity] 299 | 300 | #b only 301 | idbonly <- g > 1 & b < 1 & b > 0 & b*g == 1 & is.finite(b) & order == 1 302 | res[idbonly] <- (b[idbonly] - 1) / log(b[idbonly]) 303 | idbonly <- g > 1 & b < 1 & b > 0 & b*g == 1 & is.finite(b) & order != 1 304 | if(sum(idbonly) > 0) 305 | { 306 | surv3 <- function(x, b, k) 307 | b^(x^(1/k)) 308 | mom3 <- function(b, k) 309 | { 310 | res <- try(integrate(surv3, b, k, lower=0, upper = 1)) 311 | if(inherits(res, "try-error")) 312 | return(NaN) 313 | res$value 314 | } 315 | res[idbonly] <- sapply(1:sum(idbonly), function(i) 316 | mom3(k=order[idbonly][i], b=b[idbonly][i])) 317 | } 318 | 319 | #g only 320 | idgonly <- g > 1 & b == 1 & is.finite(g) & order == 1 321 | res[idgonly] <- log(g[idgonly]) / (g[idgonly] - 1) 322 | idgonly <- g > 1 & b == 1 & is.finite(g) & order != 1 323 | if(sum(idgonly) > 0) 324 | { 325 | surv4 <- function(x, g, k) 326 | 1/(1+(g-1)*x^(1/k)) 327 | mom4 <- function(g, k) 328 | { 329 | res <- try(integrate(surv4, g, k, lower=0, upper = 1)) 330 | if(inherits(res, "try-error")) 331 | return(NaN) 332 | res$value 333 | } 334 | res[idgonly] <- sapply(1:sum(idgonly), function(i) 335 | mom4(k=order[idgonly][i], g=g[idgonly][i])) 336 | } 337 | 338 | #main case 339 | idmain <- g > 1 & b > 0 & b != 1 & b*g != 1 & is.finite(g) & is.finite(b) & order == 1 340 | res[idmain] <- (1-b[idmain]) * log(g[idmain] * b[idmain]) / (1-g[idmain] * b[idmain]) / log(b[idmain]) 341 | idmain <- g > 1 & b > 0 & b != 1 & b*g != 1 & is.finite(g) & is.finite(b) & order != 1 342 | if(sum(idmain) > 0) 343 | { 344 | surv5 <- function(x, g, b, k) 345 | (1 - b)/( (g-1) * b^(1-x^(1/k)) + 1 - g*b ) 346 | mom5 <- function(g, b, k) 347 | { 348 | res <- try(integrate(surv5, g, b, k, lower = 0, upper = 1)) 349 | if(inherits(res, "try-error")) 350 | return(NaN) 351 | res$value 352 | } 353 | res[idmain] <- sapply(1:sum(idmain), function(i) 354 | mom5(k=order[idmain][i], g=g[idmain][i], b=b[idmain][i])) 355 | } 356 | res 357 | } 358 | 359 | 360 | #total loss 361 | tlMBBEFDR <- function(g, b) 362 | { 363 | #sanity check 364 | stopifnot(is.numeric(g)) 365 | stopifnot(is.numeric(b)) 366 | 367 | if(min(length(g), length(b)) <= 0) 368 | return(numeric(0)) 369 | m <- max(length(g), length(b)) 370 | g <- rep_len(g, length.out=m) 371 | b <- rep_len(b, length.out=m) 372 | 373 | #default to NaN 374 | res <- rep(NaN, m) 375 | 376 | #unit indicator - 377 | idDirac <- g == Inf & b > 0 & b != 1 378 | res[idDirac] <- 1 379 | 380 | #identity function 381 | ididentity <- (g > 1 & b == 0) | (g > 1 & b == Inf) | (g == 1 & b > 0 & b != 1) 382 | res[ididentity] <- 1 383 | 384 | #b only 385 | idbonly <- g > 1 & b < 1 & b > 0 & b*g == 1 & is.finite(b) 386 | res[idbonly] <- b[idbonly] 387 | 388 | #g only 389 | idgonly <- g > 1 & b == 1 & is.finite(g) 390 | res[idgonly] <- 1/g[idgonly] 391 | 392 | #main case 393 | idmain <- g > 1 & b > 0 & b != 1 & b*g != 1 & is.finite(g) & is.finite(b) 394 | res[idmain] <- 1/g[idmain] 395 | 396 | res 397 | } 398 | 399 | 400 | 401 | 402 | ### d,p,q,ec,m,tl functions MBBEFD(g,b) 403 | 404 | dMBBEFD <- dMBBEFDR 405 | 406 | pMBBEFD <- pMBBEFDR 407 | 408 | qMBBEFD <- qMBBEFDR 409 | 410 | ecMBBEFD <- ecMBBEFDR 411 | 412 | mMBBEFD <- mMBBEFDR 413 | 414 | tlMBBEFD <- tlMBBEFDR 415 | 416 | --------------------------------------------------------------------------------