R/mod_bootstrap_body.R

In MehdiChelh/triangle.tlbx: An Amazing Shiny App

# Module UI
  
#' @title   mod_bootstrap_body_ui and mod_bootstrap_body_server
#' @description  A shiny Module.
#'
#' @param id shiny id
#' @param input internal
#' @param output internal
#' @param session internal
#'
#' @rdname mod_bootstrap_body
#'
#' @keywords internal
#' @export 
#' @importFrom shiny NS tagList 
#' @import ChainLadder
mod_bootstrap_body_ui <- function(id){
  ns <- NS(id)
  
  tagList(
    customTabBox(width=12, id = ns(NULL),
           # ///////////////////////////////////////
           #  Onglet "Données & Résidus"
           # ///////////////////////////////////////
           tabPanel("Données & Résidus",
                    h4("Triangle"),
                    mod_colored_table_ui(ns("rawtriangle")),
                    hr(),
                    fluidRow(box(title = "Sigmas de Mack", solidHeader = TRUE, collapsible = TRUE,
                                 DT::dataTableOutput(ns("mack-table")), width=12, status="primary"), style="padding-right:15px; margin-bottom:-15px"),
                    hr(),
                    fluidRow(box(title = "Visualisation des sigmas de Mack", solidHeader = TRUE, collapsible = TRUE,
                                 highchartOutput(ns("mack-plot")),width=12 ,status="primary"), style="padding-right:15px; margin-bottom:-15px"),
                    hr(),
                    fluidRow(box(title = "Résidus simples", solidHeader = TRUE, collapsible = TRUE,
                                 mod_colored_table_ui(ns("residuals_unscaled-table")), width=12, status="primary"), style="padding-right:15px; margin-bottom:-15px"),
                    hr(),
                    fluidRow(box(title = "Résidus normalisés", solidHeader = TRUE, collapsible = TRUE,
                                 mod_colored_table_ui(ns("residuals_scaled-table")), width=12, status = "primary"), style="padding-right:15px; margin-bottom:-15px")
           ),
           # ///////////////////////////////////////
           #  Onglet "Résultats & Quantiles du Bootstrap"
           # ///////////////////////////////////////
           tabPanel("Résultats & Quantiles du Bootstrap",
                    h4("Résumé des résultats"),
                    selectInput(ns("results-dossier_dossier-select"), "Données de réserves Dossier/Dossier", choices = c("")),
                    DT::dataTableOutput(ns("results-final_table")),
                    hr(),
                    h4("Quantiles"),
                    numericInput(ns("results-user_percentile"), "Quantile choix utilisateur (%)",
                                 min = 0, max = 100, value = 85),
                    DT::dataTableOutput(ns("results-percentile_table"))
           ),
           # ///////////////////////////////////////
           #  Onglet "Graphiques"
           # ///////////////////////////////////////
           tabPanel("Graphiques",
                    h4("Paramètres graphiques"),
                    fluidRow(
                      column(6, 
                             sliderInput(ns("graphs-amp"), 'Amplitude des tranches de montants',
                                         min = 0, max = 50000, value = 2000, step = 500))),
                    hr(),
                    fluidRow(box(title ='Histogramme des simulations de charges', status = "primary", solidHeader = TRUE, collapsible = TRUE,
                                 plotlyOutput(ns("graphs-hist")), width=6 ),
                             box(title ='Fonction de répartition', status = "primary", solidHeader = TRUE, collapsible = TRUE,
                                 highchartOutput(ns("graphs-cdf")), width=6), style="padding-right:15px; margin-bottom:-15px"),
                    hr(),
                    fluidRow(
                      column(6, h4("Résultats de simulation par cohorte"),
                             plotOutput(ns("graphs-3"))),
                      column(6, h4("Back test latest dev yr"),
                             plotOutput(ns("graphs-4"))))
           )
    ) # end of tabsetPanel for results and graphs
  )
}
    
# Module Server
    
#' @rdname mod_bootstrap_body
#' @export
#' @keywords internal
mod_bootstrap_body_server <- function(input, output, session){
  # ////////////////////////////////////////////////
  #-------------------------------------------------
  #             Initialisation du module      
  #-------------------------------------------------
  # ////////////////////////////////////////////////
  ns <- session$ns
  # MVC - Getter et Setter :
  # -----------------
  mvc <- mvc_init_mod(session)
  get <- mvc$get
  setInput <- mvc$setInput
  getInput <- mvc$getInput
  # Local variables :
  # -----------------
  local <- reactiveValues()
  
  
  # ////////////////////////////////////////////////
  #-------------------------------------------------
  #                     Setters
  #-------------------------------------------------
  # ////////////////////////////////////////////////
  
  # Onglet 1.Données et résidus
  #------------------------------------------------------------------------------------------------------------------------
  
  # Onglet 2.Résultats & Quantiles du Bootstrap
  #------------------------------------------------------------------------------------------------------------------------
  # user_entry_percentile
  #   > percentile entré par l'utilisateur
  observe({
    setInput("bootstrap", "user_entry_percentile", {
      input[["results-user_percentile"]]
    })
  })
  
  # results-dossier_dossier-select ----
  # ---- [Observer] Update selected data
  observe({
    setInput("bootstrap", "dossier_dossier", {
      # > Required variables :
      req(input[["results-dossier_dossier-select"]])
      req(input[["results-dossier_dossier-select"]] %in% session$userData$state$imported_data[["ids"]])
      # > Operations :
      session$userData$state$imported_data[[ input[["results-dossier_dossier-select"]] ]]$data
    })
  })
  
  
  # ////////////////////////////////////////////////
  #-------------------------------------------------
  #                     Observers
  #-------------------------------------------------
  # ////////////////////////////////////////////////
  
  # results-dossier_dossier-select ----
  # ---- [Observer] Update data selection input when the user import data 
  observeEvent( session$userData$state$imported_data[["ids"]] , {
    data_ids <- names(reactiveValuesToList(session$userData$state$imported_data))
    
    choices <- session$userData$state$imported_data[["ids"]]
    choices[["Aucune"]] <- ""
    
    updateSelectInput(session = session, inputId = "results-dossier_dossier-select", choices = choices)
  })
  
  # ////////////////////////////////////////////////
  #-------------------------------------------------
  #                     Outputs
  #-------------------------------------------------
  # ////////////////////////////////////////////////
  # Raw Triangle
  # -----------
  callModule(mod_colored_table_server, "rawtriangle", reactive({ getInput("bootstrap", "data-raw_triangle") }))
  
  
  # Sigma de Mack
  # -----------
  output[["mack-table"]] <-DT::renderDataTable({
    req(get("bootstrap", "sigma_mack"))
    
    datatableWrapper(get("bootstrap", "sigma_mack"))
  })
  
  
  # Plot des sigmas de Mack
  # -----------
  output[["mack-plot"]] <- renderHighchart({
    req(get("bootstrap", "sigma_mack"))
    
    MackDT <- get("bootstrap", "sigma_mack")
    MackDTCat <- colnames(MackDT)
    MackDT <- as.numeric(MackDT)
    
    highchart() %>%
      hc_xAxis(categories = MackDTCat,title=list(text="Développement") ) %>% 
      hc_yAxis(title = list(text = paste("Distribution des sigmas de Mack"))) %>% 
      hc_add_series(data = MackDT,type = "spline",  name=paste(""), color="#f0c300")%>% 
      hc_tooltip( crosshairs = TRUE,backgroundColor = "white", borderWidth = 2,shared = TRUE)
  })
  
  
  # Triangle de résidus simples (non-normalisés)
  # -----------
  callModule(mod_colored_table_server, "residuals_unscaled-table", reactive({ get("bootstrap", "residuals_unscaled") }))
  
  # Triangle de résidus normalisés
  # -----------
  callModule(mod_colored_table_server, "residuals_scaled-table", reactive({ get("bootstrap", "residuals_scaled") }))
  
  # Tableau de résultats du bootstrap - (Diagonale, Ultime, IBNR, SD, CV)
  # -----------
  output[["results-final_table"]] <- DT::renderDataTable({
    req(get("bootstrap", "summary_table"))
    
    message_chainladder <- "Les résultats de l'onglet Chain Ladder doivent avoir été calculés au préablable"
    
    if (getInput("bootstrap", "use_chainladder_link_ratio") && getInput("bootstrap", "use_chainladder_tail_factor"))
      validate(need(get("chainladder", "link_ratio-final_value"), message_chainladder),
               need(get("chainladder", "tail_factor-final_value"), message_chainladder))
    else if (getInput("bootstrap", "use_chainladder_link_ratio"))
      validate(need(!is.null(get("chainladder", "link_ratio-final_value")), message_chainladder))
    
    summary_table <- round(get("bootstrap", "summary_table"), digits=2)
    
    datatableWrapper(summary_table, format = "thousands", buttons = TRUE)
  })
  
  # Tableau de résultats du bootstrap - (Percentiles)
  # -----------
  # TODO : corriger la fonction bootpercenttable pour éviter qu'elle bug si l'utilisateur rentre un quantile qui est déjà calculé
  #         -> Pour l'instant j'ai mis un "+ 0.0000001" pour éviter que ca bug mais ce n'est pas propre 
  output[["results-percentile_table"]] <- DT::renderDataTable({
    req(get("bootstrap", "percentile_table"))
    percentiles_toshow <- round(get("bootstrap", "percentile_table"), digits=2)
    datatableWrapper(percentiles_toshow, format = "thousands", buttons = TRUE)
  })
  
  # Graphiques
  # -----------
  output[["graphs-hist"]] <- renderPlotly({
    req(get("bootstrap", "boot_results_after_retreatment"))
    req(input[["graphs-amp"]])
    
    boot_run <- get("bootstrap", "boot_results_after_retreatment")
    
    boot_run_10000 <- as.data.frame(floor(boot_run$IBNR.Totals / input[["graphs-amp"]]) * input[["graphs-amp"]])
    
    sto_ibnr <- mean(boot_run$IBNR.Totals)
    
    # Récupère la valeur déterministe (si disponible)
    chainladder_final_table <- get("chainladder", "results_final_table")
    if (!is.null(chainladder_final_table)){
      chainladder_final_table <- chainladder_final_table[-nrow(chainladder_final_table), ] # On enlève la ligne total
      deter_ibnr <- if(input[["align_results-tail_factor"]] == "with") chainladder_final_table[["ibnr"]] else chainladder_final_table[["ibnr_sans_tf"]]
      deter_ibnr <- sum(deter_ibnr)
    }
    else 
      deter_ibnr <- sto_ibnr
    # Mise en forme
    names(boot_run_10000) <- c("Montants_IBNR")
    # Plot du graphique
    ggplotly(
      ggplot(boot_run_10000) +
        geom_bar(aes(x=Montants_IBNR), color = "#f2f3f4", fill = "#f0c300")+
        #geom_line(aes(x=Montants_IBNR),color="#f0c300")+
        geom_vline(aes(xintercept = sto_ibnr, colour = 'stochastique'))+
        # TODO remplacer le input[["align_results-switch"]] par un getInput("boot)
        geom_vline(aes(xintercept = deter_ibnr, colour = ifelse(!getInput("bootstrap", "align_results"), 'deterministe', 'stochastique')))+
        theme_minimal()+
        #ggtitle('Histogramme de simulations de charges')+
        xlab("Montants d'IBNR")+
        ylab('Effectif dans les simulations')+
        scale_colour_manual("Moyennes", 
                            values = c(stochastique="red",deterministe="lightblue")) 
    )
  })
  
  # Graphiques
  # -----------
  output[["graphs-cdf"]] <- renderHighchart({
    req(get("bootstrap", "boot_results_after_retreatment"))
    req(input[["graphs-amp"]])
    
    boot_run <- get("bootstrap", "boot_results_after_retreatment")
    boot_run_fdr <- table(floor(boot_run$IBNR.Totals / input[["graphs-amp"]]) * input[["graphs-amp"]])
    boot_run_fdr <- as.data.frame(cumsum(boot_run_fdr) / sum(table(floor(boot_run$IBNR.Totals / input[["graphs-amp"]]) * input[["graphs-amp"]])))
    boot_run_fdr <- cbind(rownames(boot_run_fdr), boot_run_fdr)
    names(boot_run_fdr) <- c('Quantiles', 'Fdr')
    
    h <- highchart() %>%
      # hc_title(text = paste("Fonction de répartition"),
      #          style = list(fontSize = "20px")) %>% 
      
      hc_xAxis(categories = boot_run_fdr$Quantiles, title = list(text = "Quantiles") ) %>% #categories=boot_run_fdr ,
      hc_yAxis(title = list(text = paste("Fdr()"))) %>% 
      hc_add_series(data = boot_run_fdr$Fdr,type = "spline",  name=paste("Répartition des IBNR"), color="#f0c300")%>%  ##8b0000
      hc_tooltip( crosshairs = TRUE,backgroundColor = "white", borderWidth = 2,shared = TRUE)
    h
    
  })
  # Graphiques
  # -----------
  output[["graphs-3"]] <- renderPlot({
    req(get("bootstrap", "boot_results_after_retreatment"))
    boot_run <- get("bootstrap", "boot_results_after_retreatment")
    
    plot(boot_run, which=3)
  })
  
  # Graphiques
  # -----------
  output[["graphs-4"]] <- renderPlot({
    req(get("bootstrap", "boot_results_after_retreatment"))
    boot_run <- get("bootstrap", "boot_results_after_retreatment")
    
    plot(boot_run,which=4)
  })
}