Skip to content
GitLab
Select Git revision
  • master default
  • IrmaraDashboard
  • 18-structuration-of-the-database
  • Risk_Heart_Map
  • patch-1
Find file BlameHistoryPermalink
mod_instant_risk_overview.R 3.50 KiB
1 
#' instant_risk_overview UI Function
2 
#'
3 
#' @description A shiny Module.
4 
#'
5 
#' @param id,input,output,session Internal parameters for {shiny}.
6 
#'
7 
#' @noRd
8 
#'
9 
#' @importFrom shiny NS tagList
10 
#' @importFrom shinyjs useShinyjs disabled
11 
mod_instant_risk_overview_ui <- function(id){
12 
  ns <- NS(id)
13 
  choices <- seq(length(rvgest::rulesets$rules))
14 
  names(choices) <- paste0(choices, ". ", rvgest::rulesets$rules)
15 
  tagList(
16 
    useShinyjs(),
17 
    fluidRow(
18 
      column(width = 6,
19 
        selectInput(
20 
          ns("ruleset"),
21 
          "Rule set",
22 
          choices,
23 
          selected = NULL,
24 
          multiple = FALSE,
25 
          selectize = TRUE,
26 
          width = NULL,
27 
          size = NULL
28 
        )),
29 
      column(width = 6,
30 
        dateInput(ns("date"), "Date:", value = Sys.Date()))),
31 
    fluidRow(
32 
      column(width = 8,
33 
             radioButtons(ns("radio_mode_select"),
34 
                          "Reservoir storage mode",
35 
                          c("manual" = "manual",
36 
                            "objective curve" = "objective",
37 
                            "real time value" = "RT"),
38 
                          selected = "RT",
39 
                          inline=T),
40 
             offset = 2)
41 
    ),
42 
    fluidRow(
43 
      lapply(seq.int(nrow(rvgest::lakes)), function(i) {
44 
        column(width = 3,
45 
          disabled(
46 
            sliderInput(ns(paste0("V", i)),
47 
                        label = paste(rvgest::lakes$name[i], "lake (hm3)"),
48 
                        value = round(getObjectiveStorage()[rvgest::lakes$name[i]]),
49 
                        min = rvgest::lakes$min[i],
50 
                        max = rvgest::lakes$max[i]))
51 
        )
52 
      })
53 
    ),
54 
    # tableOutput(ns("table"))
55 
    plotOutput(ns("plot"))
56 
  )
57
58 
}
59
60 
#' instant_risk_overview Server Function
61 
#'
62 
#' @noRd
63 
#' @import ggplot2
64 
mod_instant_risk_overview_server <- function(id, con, SGL_RT_storage) {
65 
  moduleServer(id, function(input, output, session){
66 
    ns <- session$ns
67
68 
    observeEvent({
69 
        input$radio_mode_select
70 
        input$date
7172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115
}, { if(input$radio_mode_select == "manual") { fAction <- shinyjs::enable } else { fAction <- shinyjs::disable if(input$radio_mode_select == "objective") { V <- round(getObjectiveStorage(input$date)) } else { # Real time storage iDate <- as.numeric(as.POSIXct(input$date)) timeDeviation <- abs(SGL_RT_storage[,1] - iDate) i <- which(timeDeviation == min(timeDeviation)) V <- SGL_RT_storage[i, -1] } attr(V, "names") <- NULL # Otherwise we pass an object to javascript... lapply(seq.int(4), function(i) { updateSliderInput(session, inputId = paste0("V", i), value = V[i]) }) } lapply(paste0("V", seq.int(4)), fAction) }) df <- reactive({ storages <- c(input$V1, input$V2, input$V3, input$V4) names(storages) <- lakes$name golem::print_dev(storages) calcInstantRisk(con, input$ruleset, input$date, storages) }) # output$table <- renderTable(df()) output$plot <- renderPlot( ggplot(df(), aes(x = reorder(objective, prob), y = prob)) + geom_col(aes(fill = level)) + scale_y_continuous(name = "Failure risk", labels = scales::percent_format(accuracy = 1)) + scale_x_discrete(name = "Objectives downstream the reservoirs") + coord_flip()) }) } ## To be copied in the UI # mod_instant_risk_overview_ui("instant_risk_overview_ui_1") ## To be copied in the server # mod_instant_risk_overview_server("instant_risk_overview_ui_1")