R/mod_bootstrap_compute.R

In MehdiChelh/triangle.tlbx: An Amazing Shiny App

# Module UI
  
#' @title   mod_bootstrap_compute_ui and mod_bootstrap_compute_server
#' @description  A shiny Module.
#'
#' @param id shiny id
#' @param input internal
#' @param output internal
#' @param session internal
#'
#' @rdname mod_bootstrap_compute
#'
#' @keywords internal
#' @export 
#' @importFrom shiny NS tagList 
mod_bootstrap_compute_ui <- function(id){
  ns <- NS(id)
  tagList(
  
  )
}
    
# Module Server
    
#' @rdname mod_bootstrap_compute
#' @export
#' @keywords internal
    
mod_bootstrap_compute_server <- function(input, output, session){
  
  # ////////////////////////////////////////////////
  #-------------------------------------------------
  #             Initialisation du module      
  #-------------------------------------------------
  # ////////////////////////////////////////////////
  ns <- session$ns
  # MVC - Getter et Setter :
  # -----------------
  mvc <- mvc_init_com("bootstrap", session)
  get <- mvc$get
  getInput <- mvc$getInput
  set <- mvc$set
  
  
  # ////////////////////////////////////////////////
  #-------------------------------------------------
  #               Variables calculées     
  #-------------------------------------------------
  # ////////////////////////////////////////////////
  
  # ---- Calcul des sigma de Mack
  observe({
    set("sigma_mack", { 
      req(getInput("data-raw_triangle"))
      
      # Données
      datasetshow <- getInput("data-raw_triangle")
      Charges <- datasetshow
      LR <- ata(datasetshow)
      Residus_2 <- LR[1:dim(LR)[2],]
      
      # Calcul de l'écart-type des link ratios
      vwtd <- summary(LR)[dim(summary(LR))[1],]
      for(j in 1:dim(Residus_2)[2]){
        for(i in 1:dim(Residus_2)[1]){
          Residus_2[i,j] <- (Residus_2[i,j] - vwtd[j])^2
        }
      }
      # Calcul des sigmas de Mack
      Charges_residuelles <- Residus_2
      for(j in 1:dim(Charges_residuelles)[2]){
        for(i in 1:dim(Charges_residuelles)[1]){
          Charges_residuelles[i,j] <-  Residus_2[i,j] * Charges[i,j]
        }
      }
      Charges_residuelles <- as.data.frame.matrix(Charges_residuelles)
      Charges_residuelles[is.na(Charges_residuelles) ] <- 0
      SigmaMack <- apply(Charges_residuelles,2,mean)
      SigmaMack <- as.data.frame(t(as.data.frame(round(sqrt(SigmaMack),digits=4))))
      
      # Mise en forme
      rownames(SigmaMack) <- c('Sigma')
      SigmaMack
    })
  })
    
    
  # ---- Calcul des résultats du Bootstrap
  observe({
    set("boot_results", {
      req(getInput("data-raw_triangle"))
      req(getInput("process_dist"))
      req(getInput("nb_sim"))
      req(!is.null(getInput("use_chainladder_link_ratio")))
      req(!is.null(getInput("use_chainladder_tail_factor")))
      
      # Facteur de développement à utiliser.
      #   L'utilisateur peut choisir de réutiliser les résultats de l'onglet Chain Ladder.
      if(getInput("use_chainladder_link_ratio") & getInput("use_chainladder_tail_factor")){
        req(get("chainladder", "link_ratio-final_value"))
        req(get("chainladder", "tail_factor-final_value"))
        
        coeff <- c(get("chainladder", "link_ratio-final_value"), 
                   get("chainladder", "tail_factor-final_value"))
        
      } 
      else if (getInput("use_chainladder_link_ratio")){
        req(get("chainladder", "link_ratio-final_value"))
        
        coeff <- c(get("chainladder", "link_ratio-final_value"), 1)
        
      }
      # TODO : voir avec Julie ce qui était prévu pour le tail factor.
      # else if(getInput("use_chainladder_tail_factor")){
      #   req(get("chainladder", "tail_factor-final_value"))
      #   coeff <- c(get("chainladder", "tail_factor-final_value")
      # }
      else {
        coeff <- NULL
      }
      
      BootChainLadder2_MJ(getInput("data-raw_triangle"), getInput("nb_sim"), process.dist=getInput("process_dist"),
                          Parametrique = TRUE, Progbar = TRUE,
                          RecupCoef = getInput("use_chainladder_link_ratio"), CoefRecuperes = coeff)
    })
  })
  
  
  # ---- Calcul les résultats du Bootstrap recentrés sur les valeurs de l'onglet Chain Ladder
  observe({
    set("boot_results_after_retreatment", {
      req(get("boot_results")) # recquiert d'avoir calculé au préalable les résultats non centrés
      req(!is.null(getInput("align_results")))
      req(getInput("nb_sim"))
      
      results_after_treat <- get("boot_results")
      # .... Recentrage 
      if(getInput("align_results") && !is.null(get("chainladder", "results-final_table"))){
        req(getInput("align_results-method"))
        req(getInput("align_results-tail_factor"))
        
        # IBNR selon l'onglet Chain-Ladder
        chainladder_final_table <- get("chainladder", "results-final_table")
        chainladder_final_table <- chainladder_final_table[-nrow(chainladder_final_table), ] # On enlève la ligne total
        deter_ibnr <- if(getInput("align_results-tail_factor") == "with") chainladder_final_table[["ibnr"]] else chainladder_final_table[["ibnr_sans_tf"]]
        
        # IBNR selon la méthode Bootstrap
        sto_ibnr <- rowMeans(get("boot_results")$IBNR.ByOrigin)
        sto_ibnr <- array(sto_ibnr, dim = c(length(sto_ibnr), 1, getInput("nb_sim")))
        
        # Recentrage
        if(getInput("align_results-method") == "additive"){
          results_after_treat$IBNR.ByOrigin <- get("boot_results")$IBNR.ByOrigin - sto_ibnr + deter_ibnr
        } else if(getInput("align_results-method") == "multiplicative") {
          # TODO : discuter de cette partie
          results_after_treat$IBNR.ByOrigin <- ifelse(sto_ibnr == 0, rep(deter_ibnr[1], getInput("nb_sim")), get("boot_results")$IBNR.ByOrigin * deter_ibnr / sto_ibnr)
        }
      }
      results_after_treat$IBNR.Totals <- c(colSums(results_after_treat$IBNR.ByOrigin))
      results_after_treat
    })
  })
  
  
  # ---- Calcul des résidus simples (non-normalisés)
  observe({
    set("residuals_unscaled", {
      req(get("boot_results"))
      req(getInput("data-raw_triangle"))
      
      # Résultats du bootstrap
      Initial_boot <- get("boot_results")
      
      # Résidus unscaled
      resid_out <- as.data.frame(Initial_boot$Unscaled.Residuals[ , , 1])
      
      # Mise en forme
      colnames(resid_out) <- colnames(getInput("data-raw_triangle"))
      rownames(resid_out) <- rownames(getInput("data-raw_triangle"))
      resid_out <- round(resid_out,digits=3)
      resid_out
    })
  })
  
  
  # ---- Calcul des résidus
  observe({
    set("residuals_scaled", {
      req(get("boot_results"))
      
      # Résultats du bootstrap
      Initial_boot <- get("boot_results")
      
      # Résidus scaled
      resid_out <- as.data.frame(Initial_boot$ChainLadder.Residuals[,,1])
      
      # Mise en forme
      colnames(resid_out) <- colnames(getInput("data-raw_triangle"))
      rownames(resid_out) <- rownames(getInput("data-raw_triangle"))
      resid_out <- round(resid_out,digits=3)
      resid_out
    })
  })
  
  
  # ---- Tableau de résumé des résultats
  observe({
    set("summary_table", {
      req(get("bootstrap", "boot_results_after_retreatment"))
      req(getInput("data-raw_triangle"))
      
      Bootsumry <- summary(get("bootstrap", "boot_results_after_retreatment"))
      hist_size <- nrow(getInput("data-raw_triangle"))
      
      # Ajout des charges dossier dossier
      if (!is.null(getInput("dossier_dossier")) && length(getInput("dossier_dossier")) == hist_size) {
        dossier_dossier <- as.numeric(getInput("dossier_dossier")) # convert to numeric vector
        dossier_dossier <- list("Dossier/Dossier" = c(dossier_dossier,  sum(dossier_dossier)))
      } else {
        dossier_dossier <- list("Dossier/Dossier" = 0)
      }
      
      #summary_table <- cbind(dossier_dossier, boottable(Bootsumry, as.numeric(getInput("units"))))
      summary_table <- cbind(dossier_dossier, boottable(Bootsumry, 1))
      summary_table
    })
  })
  
  
  # ---- Tableau de résultat par quantile
  observe({
    set("percentile_table", {
      req(get("bootstrap", "boot_results_after_retreatment"))
      
      Bootresults <- get("bootstrap", "boot_results_after_retreatment")
      
      Percent_values <- c(0.5,0.75,0.9,0.95,0.995,0.999, getInput("user_entry_percentile")/100 + 0.0000001) # Flemme de corriger proprement le bug pour l'instant
      
      quantiles_run <- quantile(Bootresults, probs = Percent_values)
      
      #bootpercenttable(quantiles_run, as.numeric(getInput("units")))
      
      bootpercenttable(quantiles_run, 1)
    })
  })
    
}




#' @title boottable
#' 
#' @description function to reformat bootstrap results for use in DT:Datatable
#' 
#' @param bootsumry results of the bootstrap. typically boot_results or boot_results_after_retreatment of bootstrap Backend Module.
#' @param useunits (type:numeric) Represents the unit used for displaying the results. 
#' 
boottable <- function (bootsumry, useunits) {   
  #input is BootChainLadder summary output, units for numbers 
  #produces table with headings latest, Mean ult, Mean Reserve, Total S.D, CV
  #with the final row as Total across all cohorts
  #start with by origins
  
  sboot_origin<-cbind(
    bootsumry$ByOrigin["Latest"] / useunits,
    bootsumry$ByOrigin["Mean Ultimate"] / useunits,
    bootsumry$ByOrigin["Mean IBNR"] / useunits,
    bootsumry$ByOrigin["SD IBNR"] / useunits,
    (bootsumry$ByOrigin["SD IBNR"] / bootsumry$ByOrigin["Mean IBNR"])*100
  )
  colnames(sboot_origin) <- list("Diagonale","Ultime Moyen","IBNR Moyen","Ecart-type IBNR", "CV(%)")
  #now do totals
  sboot_total<-cbind(
    bootsumry$Totals["Latest:",] / useunits,
    bootsumry$Totals["Mean Ultimate:",] / useunits,
    bootsumry$Totals["Mean IBNR",] / useunits,
    bootsumry$Totals["SD IBNR",] / useunits,
    (bootsumry$Totals["SD IBNR",] / bootsumry$Totals["Mean IBNR",])*100
  )
  colnames(sboot_total) <- list("Diagonale","Ultime Moyen","IBNR Moyen","Ecart-type IBNR", "CV(%)")
  rownames(sboot_total) <- list("Total")
  sboot_all <- rbind(sboot_origin, sboot_total) 
  return(sboot_all)
} 


#' bootpercenttable
#' 
#' @description function to reformat bootstrap percentile results for use in DT:Datatable
bootpercenttable <- function (bootquantile,useunits) {   
  #input is BootChainLadder qauntile output, units for numbers 
  #produces table with headings for reserve at default percentile values plus user-defined value 
  #with the final row as Total across all cohorts
  #start with by origins
  ncolquant <- ncol(bootquantile$ByOrigin)
  finalcolname <- colnames(bootquantile$ByOrigin[ncolquant])
  user_percentile <- substr(finalcolname, 6, 7)
  sbootquant_origin <- cbind(
    bootquantile$ByOrigin["IBNR 50%"] / useunits,
    bootquantile$ByOrigin["IBNR 75%"] / useunits,
    bootquantile$ByOrigin["IBNR 90%"] / useunits,
    bootquantile$ByOrigin["IBNR 95%"] / useunits,
    bootquantile$ByOrigin["IBNR 99.5%"] / useunits,
    bootquantile$ByOrigin["IBNR 99.9%"] / useunits,
    bootquantile$ByOrigin[ncolquant] / useunits
  )
  
  colnames(sbootquant_origin) <- list("Reserve 50%","Reserve 75%","Reserve 90%","Reserve 95%","Reserve 99.5%","Reserve 99.9%", paste("Reserve @ choix-utilisateur: ", user_percentile, "%"))
  #now do totals
  sbootquant_total<-cbind(
    bootquantile$Totals["IBNR 50%",] / useunits,
    bootquantile$Totals["IBNR 75%",] / useunits,
    bootquantile$Totals["IBNR 90%",] / useunits,
    bootquantile$Totals["IBNR 95%",] / useunits,
    bootquantile$Totals["IBNR 99.5%",] / useunits,
    bootquantile$Totals["IBNR 99.9%",] / useunits,
    bootquantile$Totals[ncolquant,] / useunits
  )
  colnames(sbootquant_total) <- list("Reserve 50%","Reserve 75%","Reserve 90%","Reserve 95%","Reserve 99.5%","Reserve 99.9%",paste("Reserve @ choix-utilisateur: ",user_percentile, "%"))
  row.names(sbootquant_total) <- list("Total")
  sbootquant_all <- rbind(sbootquant_origin, sbootquant_total) 
  return(sbootquant_all)
}