R/mod_chainladder_body.R

In MehdiChelh/triangle.tlbx: An Amazing Shiny App

# ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
# Module UI
# ///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  
#' @title   mod_chainladder_body_ui and mod_chainladder_body_server
#' @description  A shiny Module.
#'
#' @param id shiny id
#' @param input internal
#' @param output internal
#' @param session internal
#'
#' @rdname mod_chainladder_body
#'
#' @keywords internal
#' @export 
#' @include aux_fonctions_MJ.R mod_colored_table.R aux_custom_ui.R
#' @importFrom shinyWidgets materialSwitch
#' @importFrom shiny NS tagList selectInput wellPanel h2 fluidRow column 
#' @importFrom shinydashboard valueBoxOutput
#' @importFrom highcharter highchartOutput renderHighchart
#' @import plotly
mod_chainladder_body_ui <- function(id){
  
  ns <- NS(id)
  
  tagList(
    customTabBox(width=12, id = ns(NULL),
           # ///////////////////////////////////////
           #  Onglet "Traitement des coefficients"
           # ///////////////////////////////////////
           tabPanel("Traitement des coefficients",
                    # Raw Triangle
                    # -----------
                    h4("Triangle initial"),
                    mod_colored_table_ui(ns("rawtriangle")),
                    # uiOutput(ns("rawtriangle")),
                    hr(),
                    # Link Ratios
                    # -----------
                    h4("Link ratios and estimators"),
                    DT::dataTableOutput(ns("linkratios-triangle")),
                    hr(),
                    # TODO: réparer le bug graphique pour se débarasser du bricolage padding-right:15px
                    # Graphiques
                    # -----------
                    fluidRow(style = "padding-right:15px; margin-bottom:-15px",
                             # box(width = 5, title = "Charges et link ratios", solidHeader = TRUE, collapsible = TRUE,
                             #     highchartOutput(ns("devCoef")), status="primary"),
                             box(width = 12, title = "Visualisation des exclusions - moyenne des LR retenus", status = "primary", solidHeader = TRUE, collapsible = TRUE,
                                 fluidRow(style = "padding-right:15px",
                                   column(6, actionButton(ns("linkratios-plot-previousyear"), "Année précédente", icon("chevron-left"), style="width:100%")),
                                   column(6, actionButton(ns("linkratios-plot-nextyear"), "Année suivante", icon("chevron-right"), style="width:100%"))),
                                 plotlyOutput(ns("linkratios-plot")))),
                    hr(),
                    # User Entry
                    # -----------
                    fluidRow(style = "padding-right:15px; margin-bottom:-15px",
                             box(title = "Choix utilisateur", status = "primary", solidHeader = TRUE, collapsible = TRUE,
                                 DTOutput(ns("linkratios-user_entry")),
                                 tags$em("Pour entrer des valeurs manuellement: Double cliquer, puis 'Ctrl + Entrer' pour valider."), width=12)
                    ),
                    hr(),
                    # Custom Link Ratios
                    # -----------
                    fluidRow(style = "padding-right:15px; margin-bottom:-15px",
                             box(title = "Personnalisation", status = "primary", solidHeader = TRUE, collapsible = TRUE,
                                 DT::dataTableOutput(ns("LinkratiosCustom")), width=12))
           ),
           # ///////////////////////////////////////
           #            Onglet "Résultats"
           # ///////////////////////////////////////
           tabPanel("Résultats",
                    fluidRow(
                      column(12, style="padding-right:15px",
                             # User Entry
                             # -----------
                             h4("Triangle projeté"),
                             DT::dataTableOutput(ns("results-projected_triangle")),
                             hr(),
                             # Résultats
                             # -----------
                             h4("Résultats"),
                             div(style = "display:inline-block; vertical-align:top; padding-right: 5px", selectInput(ns("results-diagonal_data-select"), "Règlements à date", choices = c(""))),
                             div(style = "display:inline-block; vertical-align:top;", selectInput(ns("results-dossier_dossier-select"), "Réserves Dossier/Dossier", choices = c(""))),
                             errorOutput(ns("results-final_table-error")),
                             DT::dataTableOutput(ns("results-final_table"))
                             )
                    )
           )
    ) 
  )
}







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

#' @rdname mod_chainladder_body
#' @export
#' @importFrom shinyWidgets materialSwitch
#' @importFrom shiny selectInput wellPanel h2 fluidRow column 
#' @importFrom  shinydashboard valueBoxOutput
#' @importFrom formattable renderFormattable formattableOutput formattable area color_tile
#' @import DT
#' @keywords internal
mod_chainladder_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("linkratios-plot-year" = 1)
  
  
  # ////////////////////////////////////////////////
  #-------------------------------------------------
  #                     Setters
  #-------------------------------------------------
  # ////////////////////////////////////////////////
  
  
  # ===========================================
  #   1. Onglet "Traitement des coefficients"
  # ===========================================
  
  
  observe({
    setInput("chainladder", "link_ratio-excluded_ratios", {
      # ---- Cellules sélectionnée (exclues) du tableau de link ratios
      #       - Output: Matrice donnant les coordonées des cellules exclues
      selected_cells <- input[["linkratios-triangle-selected_cells"]]
      if(is.null(selected_cells)) NULL else t(selected_cells)
    })
  })
  
  
  observe({
    setInput("chainladder", "user_entry", {
      # ---- Valeurs entrées manuellement par l'utilisateur (tail factor + link ratios)
      #       - Output: 
      req(getInput("chainladder", "data-raw_triangle"))
      
      hist_size <- nrow(getInput("chainladder", "data-raw_triangle"))
      
      # Valeurs par défaut
      if (is.null(input[["linkratios-user_entry_cell_edit"]]))
        user_entry <- 1
      else {
        user_entry <- as.numeric(input[["linkratios-user_entry_cell_edit"]]$value[-1]) # On formate de façon à éviter des 
        user_entry[is.na(user_entry)] <- 1                                  # éventuelles erreurs de saisie.
      }
      
      # Formattage
      col_names <- c(paste0("X", 1:(hist_size-1), "-X", 2:hist_size), "Tail factor")
      matrix(user_entry, nrow = 1, ncol = hist_size, dimnames = list("Entrée manuelle", col_names))
    })
  })
  
  
  observe({
    setInput("chainladder", "user_entry_link_ratio", { 
      # ---- Link ratios entrés manuellement par l'utilisateur
      #       - Output: 
      req(getInput("chainladder", "user_entry"))
      
      user_entry <- getInput("chainladder", "user_entry")
      col_tail_factor <- which(colnames(user_entry) == "Tail factor")
      user_entry[ , - col_tail_factor] 
    })
  })
  
  
  observe({
    setInput("chainladder", "user_entry_tail_factor", { 
      # ---- Tail factor entré manuellement par l'utilisateur
      #       - Output: Un scalaire (vector de taille 1)
      req(getInput("chainladder", "user_entry"))
      
      user_entry <- getInput("chainladder", "user_entry")
      col_tail_factor <- which(colnames(user_entry) == "Tail factor")
      user_entry[, col_tail_factor] 
    })
  })
  
  
  observe({
    setInput("chainladder", "link_ratio-final_selection", {
      # ---- Link ratio sélectionnés (pour la projection du triangle).
      #       - Output: matrice de taille 2 x hist_size.
      req(getInput("chainladder", "data-raw_triangle"))
      hist_size <- ncol(getInput("chainladder", "data-raw_triangle"))
      selection <- input[["LinkratiosCustom-selected_cells"]]
      selection <- if (is.null(selection)) NULL else t(selection)
      selection <- if (!is.null(selection)) selection else cbind(3, 1:hist_size) # 3 (= Moyenne retraitée) is the default selection 
      selection 
    })
  })
  
  
  # ===========================================
  #   2. Onglet "Résultats"
  # ===========================================
  
  
  observe({
    setInput("chainladder", "diagonal_data", {
      # ---- Réserves dossier/dossier. 
      #       - Output: matrice ou vecteur selon les données importées.
      req(!is.null(input[["results-diagonal_data-select"]]) | !is.null(getInput("chainladder", "data-raw_triangle")))
      if (!isTruthy(input[["results-diagonal_data-select"]]) # Si la sélection est nulle ou vide TODO:remplacer ça par !isTruthy()
          & !is.null(getInput("chainladder", "data-raw_triangle")))
        getInput("chainladder", "data-raw_triangle")
      else{
        validate( need({ input[["results-diagonal_data-select"]] %in% session$userData$state$imported_data[["ids"]] }, label = input[["results-diagonal_data-select"]]) )
        unit<-getInput("chainladder","unit_used")
        if (unit){
          session$userData$state$imported_data[[ input[["results-diagonal_data-select"]] ]]$data/unit
        } else {
          session$userData$state$imported_data[[ input[["results-diagonal_data-select"]] ]]$data
        }
        
      }
    })
  })
  
  
  observe({
    setInput("chainladder", "dossier_dossier", {
      # ---- Réserves dossier/dossier. 
      #       - Output: matrice ou vecteur selon les données importées.
      req(input[["results-dossier_dossier-select"]])
      req(input[["results-dossier_dossier-select"]] %in% session$userData$state$imported_data[["ids"]])
      
      session$userData$state$imported_data[[ input[["results-dossier_dossier-select"]] ]]$data
    })
  })
  
  
  # ////////////////////////////////////////////////
  #-------------------------------------------------
  #                     Observers
  #-------------------------------------------------
  # ////////////////////////////////////////////////
  
  
  # ===========================================
  #   1. Onglet "Traitement des coefficients"
  # ===========================================
  
  
  observeEvent(input[["linkratios-plot-previousyear"]], {
    # ---- [Observer] bouton pour se déplacer vers l'année précédente
    local[["linkratios-plot-year"]] <- max(local[["linkratios-plot-year"]] - 1, 1)
  })
  
  
  observeEvent(input[["linkratios-plot-nextyear"]], {
    # ---- [Observer] Bouton pour se déplacer vers l'année suivante
    req(getInput("chainladder", "data-raw_triangle"))
    local[["linkratios-plot-year"]] <- min(local[["linkratios-plot-year"]] + 1, ncol(getInput("chainladder", "data-raw_triangle"))-2)
  })
  
  
  # ===========================================
  #   2. Onglet "Résultats"
  # ===========================================
  
  
  observeEvent( session$userData$state$imported_data[["ids"]] , {
    # ---- [Observer] Update data selection input when the user import data
    # TODO remplacer  session$userData$state$imported_data[["1"]] par un truc global comme les "ids" ?
    data_ids <- names(reactiveValuesToList(session$userData$state$imported_data))
    choices <- session$userData$state$imported_data[["ids"]]
    updateSelectInput(session = session, inputId = "results-diagonal_data-select", choices = choices)
  })
  
  
  observeEvent( session$userData$state$imported_data[["ids"]] , {
    # ---- [Observer] Update data selection input when the user import data 
    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
  #-------------------------------------------------
  # ////////////////////////////////////////////////
  
  
  # ===========================================
  #   1. Onglet "Traitement des coefficients"
  # ===========================================
  
  
  # 1.1 rawtriangle
  # -----------------------------------
  #   ---- [Tableau] Triangle brut
  callModule(mod_colored_table_server, "rawtriangle", reactive({ getInput("chainladder", "data-raw_triangle") }))
  
  
  # 1.2 linkratios-triangle
  # -----------------------------------
  output[["linkratios-triangle"]] <- DT::renderDataTable({
    # ---- [Tableau] Triangle de Link Ratios
    req(get("chainladder", "link_ratio-triangle"))
    
    session$sendCustomMessage("send-selectedCells",
                              list("dataTableId" = session$ns("linkratios-triangle"),
                                   options = list("onePerColumn" = FALSE,
                                                  "isUpperTriangle" = TRUE)))
    
    datatableWrapper(get("chainladder", "link_ratio-triangle"), triangle = TRUE, buttons = TRUE)
  })
  
  
  # 1.3 linkratios-plot
  # -----------------------------------
  output[["linkratios-plot"]] <- renderPlotly({
    # ---- [Graphique] Link Ratios par année de survenance
    # req(getInput("chainladder", "data-raw_triangle"))
    req(getInput("chainladder", "data-raw_triangle"))
    req(get("chainladder", "link_ratio-standard_chainladder"))
    req(get("chainladder", "link_ratio-with_expert_judgment"))
    req(get("chainladder", "link_ratio-age_to_age"))
    
    datasetshow <- getInput("chainladder", "data-raw_triangle")
    d <- nrow(datasetshow)
    y <- local[["linkratios-plot-year"]]
    
    # Cellules exclues par l'utilisateur
    selected_cells <- input[["linkratios-triangle-selected_cells"]] # selected <=> exclus 
    selected_cells <- if (is.null(selected_cells) || nrow(selected_cells)==0) NULL else selected_cells[1, selected_cells[2, ] == y]
    
    # Data à ploter
    df <- data.frame("lr.vwtd" = get("chainladder", "link_ratio-standard_chainladder")[y],
                     "lr.user" = get("chainladder", "link_ratio-with_expert_judgment")[1, y],
                     "lr.triangle" = get("chainladder", "link_ratio-age_to_age")[1:(d-y), y],
                     "loss" = datasetshow[1:(d-y), y],
                     "point.size" = ifelse(is.element(1:(d-y), selected_cells), 4 , 3),
                     "point.shape" = ifelse(is.element(1:(d-y), selected_cells), "raye", "disque"),
                     "point.color" = ifelse(is.element(1:(d-y), selected_cells), "elimines", "conserves"),
                     "expert.judgment" = ifelse(is.element(1:(d-y), selected_cells), 2, 4),
                     "year" = as.numeric(as.character(row.names(datasetshow)[1:(d-y)])), row.names = NULL)
    min_year <- min(as.numeric(as.character(df$year)))
    max_year <- min_year + d - 1
    df <- na.omit(df)
    
    # Plot
    plot_link_ratio(df, y, min_year, max_year)
  })
  
  
  # 1.4 linkratios-user_entry ----
  # -----------------------------------
  output[["linkratios-user_entry"]] <- renderDT({ 
    # ----  [Tableau] Tableau des link ratios et tail factor entrés manuellement
    getInput("chainladder", "user_entry")
    
  }, editable=list("target" = "row", 
                   "disable" = list("columns" = c(0))), 
  selection = "none",
  options=list(dom = 'Bfrtip',
               scrollY = TRUE, scrollX = TRUE, 
               ordering = FALSE, paging = FALSE, 
               searching = FALSE, info = FALSE,
               columnDefs=list(list(className = 'dt-left', targets = 'cell'),
                               list(targets = 'cell', visible = FALSE))))
  
  
  # 1.5 LinkratiosCustom ----
  # -----------------------------------
  output[["LinkratiosCustom"]] <- DT::renderDataTable({
    # ---- [Tableau] Teablau de choix de link ratio (pour la projection du triangle)
    req(getInput("chainladder", "data-raw_triangle"))
    
    # TODO: remplacer ca par l'option rowCallback dans dataTable
    selection <- isolate(getInput("chainladder", "link_ratio-final_selection"))
    
    session$sendCustomMessage("remove", list("id" = session$ns("LinkratiosCustom")));
    session$sendCustomMessage("send-selectedCells",
                              list("dataTableId" = session$ns("LinkratiosCustom"),
                                   options = list("onePerColumn" = TRUE,
                                                  "isUpperTriangle" = FALSE,
                                                  "selectedCells" = selection)))
    
    datatableWrapper(get("chainladder", "link_ratio-table"))
  })
  
  
  # ===========================================
  #   2. Onglet "Résultats"
  # ===========================================
  
  
  # 2.1 results-projected_triangle ----
  # -----------------------------------
  output[["results-projected_triangle"]] <- DT::renderDataTable({
    # ---- [Tableau] Triangle projeté
    req(get("chainladder", "results-projected_triangle"))
    projected_triangle <- round(get("chainladder", "results-projected_triangle"),2)
    datatableWrapper(projected_triangle, format = 'thousands', buttons = TRUE)
  })
  
  
  # 2.2.0 results-final_table-error ----
  # -----------------------------------
  output[["results-final_table-error"]] <- renderUI({
    
    lapply(c(get("chainladder", "diagonal_data-error"),
             get("chainladder", "dossier_dossier-error"),
             ""), function(x){
               tagList(x, tags$br())
             })
  })
  
  
  # 2.2.1 results-final_table ---- 
  # -----------------------------------
  output[["results-final_table"]] <- DT::renderDataTable({
    # ---- [Tableau] Tableau de résultat par année de projection
    req(get("chainladder", "results-final_table"))
    
    results_table <- get("chainladder", "results-final_table")
    results_table <- round(results_table)
    
    # Colonnes à mettre sur un fond bleu clair
    colonnes_style <- if (is.null(input[["results-dossier_dossier-select"]])) c("diagonale") else c("diagonale", "dossier_dossier")
    
    # Nom de colonnes
    colnames <- c("Règlements à date", "Dossier/Dossier", "Ultime sans Tail Factor", "Ultime", "IBNR sans Tail Factor", "IBNR")
    
    datatable(results_table, 
              selection = list(target = "none"), 
              extensions = c('Buttons'), 
              class = 'stripe compact', 
              colnames = colnames,
              options = list(dom = 'Bfrtip',
                             scrollY = TRUE, scrollX = TRUE,
                             ordering = FALSE, paging = FALSE, 
                             searching = FALSE, info = FALSE,
                             columnDefs = list(list(className = 'dt-left', targets = 'cell'), 
                                               list(targets = 'cell', visible = FALSE))))%>%
      formatStyle(columns = colonnes_style,
                  backgroundColor = 'lightblue')
  })
}






#' plot_link_ratio
#' 
#' @description Plot of the link ratio chart with loss and mean link ratio information
#' 
#' @param df dataframe with the following columns 
#' @param min_year used to define the minimum of the x axis
#' @param max_year used to define the maximum of the x axis   
plot_link_ratio <- function(df, year, min_year, max_year){
  a <- (max(df$loss) - min(df$loss)) / (max(df$lr.triangle) - min(df$lr.triangle))
  b <- min(df$loss) - a * min(df$lr.triangle)
  
  ay <- list(tickfont = list(size = 0),
             title = list(text = "Montants", font = list(size = 13)),
             overlaying = "y",
             showline = FALSE,
             side = "right",
             tickcolor='#FFF',
             position=0.95)
  
  ggplotly(ggplot(df, aes(x = year, y = lr.triangle)) + 
             geom_segment(df, mapping = aes(x = year, 
                                            y = min(df$lr.triangle), 
                                            xend = year, 
                                            yend = (loss - b) / a,
                                            color = point.color, 
                                            alpha = expert.judgment), size = 6) +
             geom_point(aes(size = loss, 
                            color = point.color, 
                            shape = point.shape, 
                            alpha = point.size)) + 
             
             geom_abline(slope = 0,
                         intercept = df$lr.user,
                         color = 'gray',
                         linetype = 'dashed') +
             
             geom_abline(slope = 0, 
                         intercept = df$lr.vwtd, 
                         color = '#f0c300',
                         linetype = 'dotted') +
             
             scale_y_continuous('Link ratios',
                                sec.axis = sec_axis(~ . * a + b, 
                                                    name = 'Montants'),
                                limits = c(min(df$lr.triangle),
                                           max(df$lr.triangle))) +
             
             scale_x_continuous('Années de survenance', breaks = min_year:max_year)+
             
             theme_minimal() +
             
             scale_fill_manual("",
                               labels = c('elimines','conserves'),
                               values = c('#f0c300','darkred')) + 
             
             scale_color_manual("Jugement d'expert",
                                labels = c('elimines','conserves'),
                                values = c('#f0c300','darkred')) +
             
             scale_shape_manual("",
                                labels = c('raye', 'disque'),
                                values = c(19, 4), guide = FALSE) +
             
             scale_size(guide=FALSE) +
             
             coord_cartesian(xlim = c(min_year, max_year)) +
             
             theme(legend.position = "bottom"),
           
           tooltip = c('Annee', 'Link_ratio', 'intercept', 'Montant')) %>%
    
    add_lines(x = ~ year, y = ~ loss, yaxis = "y2",
              data = df, showlegend = FALSE, inherit = FALSE, opacity = 0.005) %>% 
    
    layout(yaxis2 = ay,
           title = list(title = paste("Année de développement", year), font = list(size = 12)),
           legend = list(orientation="h", 
                         x = 0.4, 
                         y = -0.2))
}