R/splicing_support.R

In Atan1988/FlexFit: Fits Severity distributions for Insurance data

#' @title create spliced severity curve obj
#' @param FUN1 string name of the first distribution, such as lnorm for lognormal
#' @param pars1 named list of parameters of first distribution
#' @param d  the point of splicing
#' @param FUN2 string name of the second distribution, such as lnorm for lognormal
#' @param pars2 named list of parameters of second distribution
#' @export
create_spliced_severity_curve <- function(FUN1, pars1, d, FUN2, pars2) {
  structure(list(FUN1 = FUN1,
                 pars1 = pars1,
                 d = d,
                 FUN2 = FUN2,
                 pars2 = pars2
  ), class = "spliced")
}

#' @export
LEV.spliced <- function(obj, x) {
   dist1_obj <- list(
     distr = obj$FUN1,
     parameters = obj$pars1
   )

   dist2_obj <- list(
     distr = obj$FUN2,
     parameters = obj$pars2
   )

   lev <- ifelse(x <= obj$d, LEV(dist1_obj, rep(0, length(x)), x),
                  LEV(dist1_obj, 0, obj$d) + Sx(obj, obj$d) * LEV(dist2_obj, 0, pmax(x - obj$d, 0)))
   return(lev)
}

#' @export
Sx.spliced <- function(obj, x){

  S <- ifelse(x <= obj$d,
         Sx(
           list(
             distr = obj$FUN1,
             parameters = obj$pars1
           ),
           x
         ),
         Sx(
           list(
             distr = obj$FUN1,
             parameters = obj$pars1
           ),
           obj$d
         ) *
           Sx(
             list(
               distr = obj$FUN2,
               parameters = obj$pars2
             ),
             x - obj$d
           )

  )
  return(S)
}


#' @export
Qx.spliced <- function(obj, p){
  s <- 1 - p
  sd1 <- Sx(
    list(
      distr = obj$FUN1,
      parameters = obj$pars1
    ),
    obj$d
  )

  Q <- ifelse(s >= sd1,
    do.call(qfunc,
            args = append(
              list(
                p = p,
                FUN = obj$FUN1
              ),
              obj$pars1
            )
    ),
     obj$d + do.call(qfunc,
            args = append(
              list(
                p = pmax(1 - s/sd1, 0),
                FUN = obj$FUN2
              ),
              obj$pars2
            )
          )
  )
  return(Q)
}



#' @export
Rx.spliced <- function(obj, n){
  p <- runif(n)
  Qx(obj, p)
}


#' @export
shift_mixed_expo <- function(ws, scales, d) {
  ws1 <- exp(-d/exp(scales)) * exp(ws) / sum(exp(ws))
  ws2 <- ws1 / sum(ws1)
  list(
    ws = log(ws2),
    scales = scales
  )
}