R/mod_bootstrap_side.R

In MehdiChelh/triangle.tlbx: An Amazing Shiny App

# Module UI
  
#' @title   mod_bootstrap_side_ui and mod_bootstrap_side_server
#' @description  A shiny Module.
#'
#' @param id shiny id
#' @param input internal
#' @param output internal
#' @param session internal
#'
#' @rdname mod_bootstrap_side
#'
#' @keywords internal
#' @export 
#' @importFrom shiny NS tagList
#' @importFrom shinyWidgets materialSwitch awesomeRadio
mod_bootstrap_side_ui <- function(id){
  ns <- NS(id)
  tagList(
    wellPanel(id="CLBoot_inputpanel", style = "padding-bottom: 0px;",
              # Choix config
              selectInput(ns("method"), label = "Select Configuration",
                          choices=c("Config 1")),
              wellPanel(
                # Choix jeu de données
                selectInput(ns("data"), label="Select Data",
                            choices=c("")),
                textOutput(ns("data-error"), container = function(...){ tag("error", list(...)) } ),
                # Choix unité (pour l'affichage des chiffres)
                selectInput(ns("units"), 
                            "Unit for display purposes:", 
                            c("Units" = 1, "Hundreds" = 100, "Thousands" = 1000, "Millions" = 1000000, "Billions" = 1000000000),
                            selected = 1)
              ),
              wellPanel(id = ns("use_chainladder"),
                tags$b("Récupérer les résultats de l'onglet Chain Ladder:"),
                tags$div(
                materialSwitch(ns("use_chainladder_link_ratio"), "Récupérer les link ratios", status = "info", right = TRUE), style="padding-top: 10px"),
                materialSwitch(ns("use_chainladder_tail_factor"), "Récupérer le tail factor", status = "info", right = TRUE)
              ),
              wellPanel(id = ns("align_results"),
                tags$b("Traitement sur les résultats du bootstrap:"),
                tags$div(
                  materialSwitch(ns("align_results-switch"), "Recentrer les résultats sur ceux de l'onglet Chain Ladder", status = "info", right = TRUE), style="padding-top: 10px"),
                conditionalPanel(
                  condition=paste0("input['", ns("align_results-switch"), "']"),
                  awesomeRadio(ns("align_results-method"), "Méthode de recentrage", choices = c("Additive" = "additive",
                                                                                                "Multiplicative" = "multiplicative"), selected = "additive"),
                  awesomeRadio(ns("align_results-tail_factor"), "Données déterministes", choices = c("Avec Tail Factor" = "with", 
                                                                                                     "Sans Tail Factor" = "without"), selected = "with"))
              ),
              wellPanel(
                awesomeRadio(ns("process_dist"), "Process distribution", 
                             choices = list("ODP"="od.pois", "Gamma"="gamma"), selected = "gamma")
              ),
              wellPanel(
                numericInput(ns("nb_sim"), "Number of simulations",
                             min = 0, max = 1000000, value = 5000)
              ),
              wellPanel(
                tags$em("[Non utilisé actuellement]"),
                awesomeRadio(ns("seed_is_used"),"Simulation seed option", 
                             choices = c("Not set" = 0, "Specify" = 1), selected = 0),
                conditionalPanel(
                  condition = paste0("input['",  ns("seed_is_used"), "'] == 1"),
                  numericInput("seed_value", "Simulation seed value",value=1328967780,
                               min = 0)
                )
              )
    )
  )
}
    
# Module Server
    
#' @rdname mod_bootstrap_side
#' @export
#' @keywords internal
    
mod_bootstrap_side_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()
  set <- function(key, value){ local[[key]] <- value }
  
  # ////////////////////////////////////////////////
  #-------------------------------------------------
  #                     Setters
  #-------------------------------------------------
  # ////////////////////////////////////////////////
  # Set the inputs of Backend Modules
  # ------------------
  observe({
    # Backend Module - Bootstrap
    # ------------------------
    setInput("bootstrap", "units", { 
      input[["units"]]
    })
    setInput("bootstrap", "process_dist", { 
      input[["process_dist"]]
    })
    setInput("bootstrap", "use_chainladder_link_ratio", { 
      input[["use_chainladder_link_ratio"]]
    })
    setInput("bootstrap", "use_chainladder_tail_factor", { 
      input[["use_chainladder_tail_factor"]]
    })
    setInput("bootstrap", "nb_sim", {
      nb_sim<-input[["nb_sim"]]
      try({
        if(nb_sim<=0){
          nb_sim<-1
          updateNumericInput(session,"nb_sim",label="Number of simulations",
                             min=1,max = 1000000, value = nb_sim)
        }
      },silent=TRUE)
      nb_sim
    })
    setInput("bootstrap", "align_results", { 
      input[["align_results-switch"]]
    })
    setInput("bootstrap", "align_results-method", { 
      input[["align_results-method"]]
    })
    setInput("bootstrap", "align_results-tail_factor", { 
      input[["align_results-tail_factor"]]
    })
  })
  
  
  # ////////////////////////////////////////////////
  #-------------------------------------------------
  #                     Observers
  #-------------------------------------------------
  # ////////////////////////////////////////////////
  # Data Selection
  # --------------
  # > Update data selection input when the user import data
  # --------------
  observeEvent( session$userData$state$imported_data[["ids"]] , {
    choices <- session$userData$state$imported_data[["ids"]]
    
    updateSelectInput(session = session, inputId = "data", choices = choices)
    
    # Par défault: assigne au premier jeu de donnée importé
    setInput("bootstrap", "data-raw_triangle", {
      session$userData$state$imported_data[[ "1" ]]$data/as.numeric(input$units)
    })
  })
  
  
  # > Update selected data
  # --------------
  observe({
    # 1. Test data validity
    set("data-raw_triangle-error", {
      req(input[["data"]])
      
      # Validate data exist
      validate( need({ input[["data"]] %in% session$userData$state$imported_data[["ids"]] }, label = input[["data"]] ))
      data <- session$userData$state$imported_data[[ input[["data"]] ]]$data
      print(data)
      # Validate data format
      validateDontStop(need({ nrow(data) == ncol(data) }, 
                            "Le jeu de données choisi n'a pas le même nombre de lignes que de colonnes. Attention à vérifier les paramètres choisis lors de l'import des données."),
                       need({ is.numeric(data) },
                            "Le jeu de données choisi semble contenir des cellules qui ne peuvent être interprétée comme numériques. Attention à vérifier les paramètres choisis lors de l'import des données."),
                       need({is.na(any(data<=0))},
                            "Le jeu de données choisi semble contenir des valeurs nulles ou négatives. Pour la méthode du Bootstrap, chargez uniquement des triangles avec valeurs strictement positives."))
    })
    # 2. If data valid / not valid, show / hide content
    if (isTruthy(local[["data-raw_triangle-error"]])) {
      shinyjs::hide("content")
      shinyjs::hide("total_ibnr")
      shinyjs::show("content-load_data_message")
      shinyjs::show("data-error")
    } else{
      shinyjs::show("content")
      shinyjs::show("total_ibnr")
      shinyjs::hide("content-load_data_message")
      shinyjs::hide("data-error")
    }
    # 3. Process data (load data in this case)
    setInput("bootstrap", "data-raw_triangle", {
      req(input[["data"]])
      
      req(is.null(local[["data-raw_triangle-error"]]))
      
      session$userData$state$imported_data[[ input[["data"]] ]]$data/as.numeric(input$units)
    })
  })
  
  
  # > Connexion chainladder - bootstrap
  # --------------
  observeEvent(c(getInput("chainladder", "data-raw_triangle"), getInput("bootstrap", "data-raw_triangle")), {
    req(getInput("chainladder", "data-raw_triangle"))
    req(getInput("bootstrap", "data-raw_triangle"))
    
    if (all(getInput("chainladder", "data-raw_triangle") == getInput("bootstrap", "data-raw_triangle"), na.rm = TRUE)){
      shinyjs::show("use_chainladder")
      shinyjs::show("align_results")
    } else {
      shinyjs::hide("use_chainladder")
      shinyjs::hide("align_results")
    }
  })
  
  
  # ////////////////////////////////////////////////
  #-------------------------------------------------
  #                     Outputs
  #-------------------------------------------------
  # ////////////////////////////////////////////////
  output[["data-error"]] <- renderText({
    
    local[["data-raw_triangle-error"]]
    
  })
}