R/mod_chainladder_compute.R

In MehdiChelh/triangle.tlbx: An Amazing Shiny App

# ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
# Module UI [Not necessary for backend modules]
# ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

# ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
# Module Server
# ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

#' @title   mod_chainladder_compute_ui and mod_chainladder_compute_server
#' @description  This is an "abstract" module. Only the server par is used. 
#' The compute sub-module is used as an abstract module that centralize all the reactive calculations.
#' 
#' @param input internal
#' @param output internal
#' @param session internal
#' 
#' @rdname mod_chainladder_compute
#' @export
#' @keywords internal
mod_chainladder_compute_server <- function(input, output, session){
  
  # ////////////////////////////////////////////////
  #-------------------------------------------------
  #             Initialisation du module      
  #-------------------------------------------------
  # ////////////////////////////////////////////////
  ns <- session$ns
  # MVC - Getter et Setter :
  # -----------------
  mvc <- mvc_init_com("chainladder", session)
  get <- mvc$get
  getInput <- mvc$getInput
  set <- mvc$set
  
  
  # ////////////////////////////////////////////////
  #-------------------------------------------------
  #               Variables calculées     
  #-------------------------------------------------
  # ////////////////////////////////////////////////
  
  
  # ---- Triangle de link_ratios. Contient également les facteur de développement simples et pondérés
  observe({
    set("link_ratio-age_to_age", {
      req(getInput("data-raw_triangle"))
      rawtriangle <- getInput("data-raw_triangle")
      ata(rawtriangle)
      #  Exemple d'output :
      # > rawtriangle <- matrix(1:15, 3, 5))
      # > link_ratio-age_to_age
      # [,1]  [,2]  [,3]  [,4]
      # [1,] 4.000 1.750 1.429 1.300
      # [2,] 2.500 1.600 1.375 1.273
      # [3,] 2.000 1.500 1.333 1.250
      # smpl 2.833 1.617 1.379 1.274
      # vwtd 2.500 1.600 1.375 1.273
    })
  })
  
  
  # ---- Simples facteurs de développement de Chain Ladder.
  observe({
    set("link_ratio-triangle", {
      req(getInput("data-raw_triangle"))
      rawtriangle <- getInput("data-raw_triangle")
      link_ratios <- summary(ata(rawtriangle), digits = 3)
      link_ratios[which(!(rownames(link_ratios) %in% c("smpl", "vwtd"))), ]
      #  Exemple d'output :
      # > rawtriangle <- matrix(1:15, 3, 5))
      # > link_ratio-triangle
      # [,1]  [,2]  [,3]  [,4]
      # [1,] 4.000 1.750 1.429 1.300
      # [2,] 2.500 1.600 1.375 1.273
      # [3,] 2.000 1.500 1.333 1.250
    })
  })
  
  
  # ---- Simples facteurs de développement de Chain Ladder.
  observe({
    set("link_ratio-standard_chainladder", {
      req(getInput("data-raw_triangle"))
      rawtriangle <- getInput("data-raw_triangle")
      attr(ata(rawtriangle), "vwtd")
    })
  })  
    
  
  # ---- Facteurs de développement avec prise en compte des exclusions de coefficients.
  observe({
    set("link_ratio-with_expert_judgment", {
      req(getInput("data-raw_triangle"))
      req(get("link_ratio-age_to_age"))
      req(getInput("user_entry"))
      
      datasetshow <- getInput("data-raw_triangle")
      d <- nrow(datasetshow) - 1
      chain1_link <- get("link_ratio-age_to_age")
      
      # Récupère les éventuelles exclusions de coefficients
      selection <- getInput("link_ratio-excluded_ratios")
      selection <- if (is.null(selection)) NULL else selection
      
      # Calcul des link ratios avec jugement d'expert
      CustomCoef <- custom_link_ratio(selection = selection,
                                      rawtriangle = datasetshow,
                                      link_ratio_triangle = chain1_link)
      CustomCoef
    })
  })
    
  
  # ---- Calcul des link ratios prenant en compte les jugements d'expert
  observe({
    set("link_ratio-table", {
      req(getInput("data-raw_triangle"))
      req(get("link_ratio-age_to_age"))
      req(getInput("user_entry"))
      req(get("link_ratio-with_expert_judgment"))
      
      datasetshow <- getInput("data-raw_triangle")
      d <- nrow(datasetshow) - 1
      
      # Link ratios sans jugement d'expert
      # ----------------------------------
      chain1_link <- get("link_ratio-age_to_age") #session$userData$state$chainladder$compute[["link_ratio-age_to_age"]]
      chain1_sum <- summary(chain1_link, digits=3)["smpl", ] # keep only the average link ratio and format with 3 digits
      chain1_vwtd <- summary(chain1_link, digits=3)["vwtd", ]
      
      # Link ratios avec jugement d'expert
      # ----------------------------------
      CustomCoef <- get("link_ratio-with_expert_judgment")
      
      # Link ratios entrés manuellement (hors tail factor)
      # ----------------------------------
      user_entry <- if (is.null(getInput("user_entry_link_ratio"))) rep(1, d) else getInput("user_entry_link_ratio")
      
      
      link_out <- rbind(chain1_sum,
                        chain1_vwtd,
                        CustomCoef,
                        user_entry)
      # Tail factor
      # ----------------------------------
      link_out <- cbind(link_out, 1)
      link_out["user_entry", ncol(link_out)] <- if (is.null(getInput("user_entry_tail_factor"))) 1 else getInput("user_entry_tail_factor")
       
      # Format d'affichage
      # ------------------
      colnames(link_out)[ncol(link_out)] <- "Tail factor"
      row.names(link_out)[1] <- "Moyenne simple"
      row.names(link_out)[2] <- "Moyenne pondérée"
      row.names(link_out)[3] <- "Moyenne retraitée"
      row.names(link_out)[nrow(link_out)] <- "Entrée manuelle"
      
      link_out
    })
  })
  
  
  # ---- Vecteur final de link_ratios sélectionnés par l'utilisateur
  observe({
    set("link_ratio-final_value", {
      # TODO : corriger cette partie une fois que le mécanisme de sélection en javascript sera écrit
      # TODO : corriger : bug lorsque l'on désélectionne tout
      req(get("link_ratio-table"))
      req(getInput("data-raw_triangle"))
      d <- ncol(getInput("data-raw_triangle"))
      
      
      # Récupération de la sélection
      col_tail_factor <- which(colnames(get("link_ratio-table")) == "Tail factor")
      nb_years <- ncol(getInput("data-raw_triangle"))
      selection <- getInput("link_ratio-final_selection")
      selection <- if (is.null(selection)) cbind(2, 1:d) else selection
      selection <- selection[selection[, 2] != col_tail_factor, ] # enlève la partie tail factor
      # TODO : faire ça directement dans la partie serveur ou mieux : côté client en JS
      selection <- selection[!duplicated(selection[, 2], fromLast = TRUE), ]
      
      # Validation des données (non-complet)
      # TODO : afficher un message en cas de données non satisfaisantes
      final_link_ratio <- get("link_ratio-table")[selection]
      final_link_ratio <- c(final_link_ratio, rep(1, max(nb_years-1 - length(final_link_ratio), 0))) # padding pour éviter des erreurs par la suite (à enlever une fois que la partie en Javascript sera faite)
      final_link_ratio
    })
  })
  
  
  # ---- tail factor retenu in fine par l'utilisateur
  observe({
    set("tail_factor-final_value", {
      req(get("link_ratio-table"))
      req(getInput("data-raw_triangle"))
      d <- ncol(getInput("data-raw_triangle"))
      # req(getInput("link_ratio-final_selection"))
      
      # Récupération des données
      col_tail_factor <- which(colnames(get("link_ratio-table")) == "Tail factor")
      selection <- getInput("link_ratio-final_selection")
      selection <- if (is.null(selection)) cbind(2, 1:d) else selection
      selection <- selection[selection[, 2] == col_tail_factor, , drop=FALSE] # consèrve uniquement la sélection du tail factor
      
      # Validation
      # TODO : afficher un message en cas de données non satisfaisantes
      final_tail_factor <- if (nrow(selection) != 0) get("link_ratio-table")[selection] else 1 # Tail factor = 1 dans le cas où l'utilisateur n'a sélectionné aucune case dans la colonne tail factor 
      final_tail_factor <- if (!is.null(final_tail_factor)) final_tail_factor else 1
      final_tail_factor <- if (length(final_tail_factor) > 1)  final_tail_factor[1] else final_tail_factor
      final_tail_factor
    })
  })
  
  
  # ===========================================
  #   Tableaux de résultat
  # ===========================================
  
  
  # ---- Triangle projeté
  observe({
    set("results-projected_triangle", {
      req(getInput("data-raw_triangle"))
      req(get("link_ratio-final_value"))
      req(get("tail_factor-final_value"))
      
      data <- getInput("data-raw_triangle")
      link_ratio <- get("link_ratio-final_value")
      tail_factor <- get("tail_factor-final_value")
      
      nb_year <- ncol(data) # on s'attend à avoir ncol() == nrow()
      for (y in 2:nb_year) # On s'attend à avoir au moins 2 années dans nos données
        data[(nb_year - (y-2)):nb_year, y] <- data[(nb_year - (y-2)):nb_year, y-1] * link_ratio[y-1]
      data
    })
  })
    
    
  # ---- Tableau final de résultats
  observe({
    # 1. Test data validity
    set("dossier_dossier-error", {
      req(getInput("dossier_dossier"))
      req(getInput("data-raw_triangle"))
      
      nb_year <- ncol(getInput("data-raw_triangle"))
      dossier_dossier <- getInput("dossier_dossier")
      
      validateDontStop(need(dossier_dossier, "dossier_dossier"),
                       need(length(dossier_dossier) == nb_year, paste0("Le format attendu pour les réserves Dossier/Dossier est un vecteur colonne de longueur égale la profondeur d'historique (", nb_year, " ans ici).")))
    })
    set("diagonal_data-error", {
      req(getInput("diagonal_data"))
      req(getInput("data-raw_triangle"))
      
      nb_year <- ncol(getInput("data-raw_triangle"))
      diagonale <- getInput("diagonal_data")
      
      validateDontStop(need(!is.null(diagonale), "diagonale"),
                       need(ncol(diagonale) == nb_year && nrow(diagonale) == nb_year, paste0("Le format attendu pour les Règlements à date est un triangle ou une matrice carré avec un nombre de ligne/colonne égale la profondeur d'historique (", nb_year, " ans ici).")))
    })
    # 2. If data valid / not valid, show / hide content
    
    # 3. Process data (compute IBNR results in this case)
    set("results-final_table", {
      req(getInput("data-raw_triangle"))
      req(get("results-projected_triangle"))
      req(get("tail_factor-final_value"))
      
      nb_year <- ncol(getInput("data-raw_triangle"))
      
      # selected triangle for diagonale
      # Hypothèse : getInput("diagonal_data") est une matrice carrée de même taille que getInput("data-raw_triangle")
      #             Les années de survenance sont ordonnées de la même façon dans le tableau
      diagonale <- if(isTruthy(get("diagonal_data-error"))) rep(0, nb_year) else rev(getInput("diagonal_data")[(nb_year-1)*(1:nb_year) + 1])
      
      # hypothèse : dossier_dossier est un vecteur/matrice colonne de taille identique au nombre de colonnes/lignes que getInput("data-raw_triangle")
      dossier_dossier <- if(isTruthy(get("dossier_dossier-error"))) rep(0, nb_year) else getInput("dossier_dossier")
      
      ultime_sans_tf <- get("results-projected_triangle")[, nb_year]
      
      ultime <- ultime_sans_tf * get("tail_factor-final_value")
      
      # NB: à ce stade normalement on sait déjà que les données sont de type numeric et qu'elles ont au plus deux dimensions
      # TODO : ajouter un test pour vérifier que dossier_dossier a bien les bonnes dimensions
      # validate(need(!is.null(dossier_dossier), "dossier_dossier"),
      #          need(!is.null(diagonale), "diagonale"),
      #          need(length(dossier_dossier) == nb_year, "format dossier_dossier"),
      #          need(length(diagonale) == nb_year, "format diagonale"))
      
      ibnr_sans_tf <- ultime_sans_tf - diagonale # ultime prédit par méthode de chain ladder
      
      ibnr <- ultime - diagonale
      
      psap <- ultime - diagonale
      
      results_table <- data.frame(list(
        "diagonale" = diagonale,
        "dossier_dossier" = dossier_dossier,
        "ultime_sans_tf" = ultime_sans_tf,
        "ultime" = ultime,
        "ibnr_sans_tf" = ibnr_sans_tf,
        "ibnr" = ibnr
      ))
      results_table <- rbind(results_table, colSums(results_table))
      rownames(results_table)[nrow(results_table)] <- "Total"
      results_table
    })
  })
  observe({
    set("dossier_dossier-error2", {
      req(getInput("dossier_dossier"))
      req(getInput("data-raw_triangle"))
      
      nb_year <- ncol(getInput("data-raw_triangle"))
      dossier_dossier <- getInput("dossier_dossier")
      
      validateDontStop(need(dossier_dossier, "dossier_dossier"),
                       need(length(dossier_dossier) == nb_year, "format dossier_dossier"))
    })
  })
}





#' @title custom_link_ratio
#' 
#' @description Calcul des link ratios pondérés par les coefficients sélectionnés
#'
#' @param selection
#' @param rawtriangle 
#' @param link_ration_triangle
#' 
custom_link_ratio <- function(selection, rawtriangle, link_ratio_triangle) {
  
  d <- nrow(rawtriangle) - 1
  
  # TODO: Discuter avec Julie.
  Poids <- matrix(1, d, d)
  Poids[selection] <- 0
  
  # Lignes CustomCoeff{0-5} 
  #   > Permet de voir l'impact des sélection de coefficients et de la profondeur d'historique sur les résultats
  nb_CustomCoef <- pmin(d, 5) + 1
  CustomCoef <- matrix(1, nrow = nb_CustomCoef, ncol = d, 
                       dimnames = list(c("", "Moyenne 1 an", paste0("Moyenne ", 2:(nb_CustomCoef-1), " ans")), 1:d))
  
  # Calcul des customcoeff
  for (i in 1:d){
    # TODO: Discuter avec Julie
    CustomCoef[1, i] <- sum(na.omit(rawtriangle[1:(d-i+1),i] * Poids[1:(d-i+1),i] * link_ratio_triangle[1:(d-i+1),i])) / sum(na.omit(rawtriangle[1:(d-i+1),i] * Poids[1:(d-i+1),i]))
    for (j in 1:(nb_CustomCoef-1)){
      if(d-i+1-j >= 0)
        CustomCoef[j+1, i] <- round(sum(na.omit(rawtriangle[(d-i+1-j+1):(d-i+1),i])*na.omit(Poids[(d-i+1-j+1):(d-i+1),i])*na.omit(link_ratio_triangle[(d-i+1-j+1):(d-i+1),i]))/sum(na.omit(rawtriangle[(d-i+1-j+1):(d-i+1),i])*na.omit(Poids[(d-i+1-j+1):(d-i+1),i])),digits=3)
      else 
        CustomCoef[j+1, i] <- 1
    }
  }
  
  CustomCoef <- round(CustomCoef,digits=3)
  return(CustomCoef)
  
}