R/curve_fitting_support.R

In Atan1988/FlexFit: Fits Severity distributions for Insurance data

#' @title loss data filter
#' @param data loss data data frame
#' @param loss_var loss variable
#' @param cutoff_var cutoff variable
#' @param trended_cutoff_var trended cutoff variable
#' @param trended_loss_var trended cutoff variable
#' @param min_loss minminum loss to be included
#' @param rtrunc right truncation point
#' @export
loss_filter  <- function(data, loss_var = 'GC_TInc',
                         cutoff_var = "cutoff", trended_cutoff_var = NULL,
                         trended_loss_var = NULL,
                         min_loss = 5e5, rtrunc = Inf) {
  Data1 <- data  %>% dplyr::filter(!!rlang::sym(cutoff_var) < !!rlang::sym(loss_var)) %>%  #remove losses below cutoff
    dplyr::filter(!!rlang::sym(loss_var) > min_loss) %>%  #remove losses under 100k. FYI - 28 losses over 1M
    dplyr::mutate(!!rlang::sym(cutoff_var) := pmax(!!rlang::sym(cutoff_var), min_loss))

  if (!is.null(trended_loss_var) & !is.null(trended_cutoff_var)) {
    Data1 <- Data1 %>%
      dplyr::mutate(
        !!rlang::sym(trended_cutoff_var) := (!!rlang::sym(cutoff_var) *
                    !!rlang::sym(trended_loss_var) / !!rlang::sym(loss_var))
      )
  }
  return(Data1 %>% dplyr::filter(!!rlang::sym(trended_loss_var) < rtrunc))
}


#' @title fit mixed exponential distribution
#' @param df  loss data frame
#' @param FUN distribution to fit
#' @param min_loss minimal loss cutoff, applies to untrended losses
#' @param loss_var untrended losses variable, GU
#' @param cutoff_var untrended loss cutoff variable
#' @param trended_loss_var trended losses variable, GU
#' @param trended_cutoff_var trended cutoff variable
#' @param fixed_scale T or F, whether to fix the scale parameters at initial value
#' @param cap_loss maximum observed loss limit, above this point, assume losses are censored at this point
#' @param inis log of initial ISO parameters, the fit uses mixexp distribution which take the exponent of the parameters
#' @param rtrunc truncation point at the right side
#' @export
fit_mixed_expo <- function(df, FUN = 'mixexp',
                           min_loss = 0, loss_var = 'GC_TInc', cutoff_var = "cutoff",
                           trended_loss_var = 'GU_Loss_Trended', trended_cutoff_var = 'Att_Trended',
                           fixed_scale = T, cap_loss = Inf, inis = NULL,
                           rtrunc = Inf
                           ) {
  df1 <- loss_filter(df, loss_var, cutoff_var, trended_cutoff_var = trended_cutoff_var,
                     trended_loss_var = trended_loss_var, min_loss, rtrunc)
  n_pars <- length(inis) / 2

  if (fixed_scale) {
    fit_free <- sevfit(y = pmin(df1[[trended_loss_var]] - df1[[trended_cutoff_var]], cap_loss),
                       Att = df1[[trended_cutoff_var]], FUN = FUN,
                       rtrunc = rtrunc,
                       Lmt = cap_loss,
                       ini = inis[1:n_pars],
                       parnames = c('ws'),
                       fixedpar = inis[(n_pars+1):(2*n_pars)],
                       fixedparn = 'scales',
                       control = list(iterlim = 50000))
  } else {
    fit_free <- sevfit(y = pmin(df1[[trended_loss_var]] - df1[[trended_cutoff_var]], cap_loss),
                       Att = df1[[trended_cutoff_var]], FUN = FUN,
                       rtrunc = rtrunc,
                       Lmt = cap_loss,
                       ini = inis,
                       parnames = c('ws', 'scales'),
                       control = list(iterlim = 5000))
  }

  return(fit_free)
}


#' @title parse mixed expo fit variables
#' @param obj sevfit object
#' @param name name of the parsed data
#' @param par_trans any parameter transformation applied
#' @export
parse_mixed_expo_var <- function(obj, name = 'fixed_scale', par_trans = exp) {
  obj$parameters %>% as.data.frame() %>%
    dplyr::mutate_all(par_trans) %>%
    dplyr::mutate(
      ws = ws / sum(ws)
    ) %>%
    dplyr::mutate(
      distr = obj$distr,
      name = name
    )
}

#' @title LEV calculations
#' @param x object that stores the parameters
#' @export
LEV <- function(x, ...) UseMethod('LEV')

#' @title Sx calculations
#' @param x object that stores the parameters
#' @export
Sx <- function(x, ...) UseMethod('Sx')

#' @title Qx calculations
#' @param x 0 - 1 quantile of the distribution
#' @export
Qx <- function(x, ...) UseMethod('Qx')

#' @title Rx calculations
#' @param n number of data points sampled from the distribution
#' @export
Rx <- function(x, ...) UseMethod('Rx')

#' @title LEV calucation for Ironfit object
#' @param fit_res result of sevfit function
#' @param lower attachment
#' @param upper attachment + limit
#' @export
LEV.Ironfit <- function(fit_res, lower, upper) {
  par_for_integrate <- append(list(f = S, subdivisions = 10000,
                                   Fx = fit_res$distr),
                              fit_res$parameters)

  levs <- mapply(integrate, lower = lower, upper = upper,
                 MoreArgs = par_for_integrate, SIMPLIFY = F)
  unlist(lapply(levs, function(x) x$value))
}

#' @export
LEV.list <- function(lst, lower, upper) {
  par_for_integrate <- append(list(f = S, subdivisions = 10000,
                                   Fx = lst$distr),
                              lst$parameters)
  levs <- mapply(integrate, lower = lower, upper = upper,
                 MoreArgs = par_for_integrate, SIMPLIFY = F)
  unlist(lapply(levs, function(x) x$value))
}

#' @title Sx calucation for Ironfit object
#' @param fit_res result of sevfit function
#' @param lower attachment
#' @export
Sx.Ironfit <- function(fit_res, lower) {
  par_for_S <- append(
    list(x = lower,
         Fx = fit_res$distr),
    fit_res$parameters
  )

  do.call(S, args = par_for_S)

}

#' @export
Sx.list <- function(lst, lower) {
  par_for_S <- append(
    list(x = lower,
         Fx = lst$distr),
    lst$parameters
  )

  do.call(S, args = par_for_S)
}