feat: Annual risk assessment for one objective at one station

- Still color inversion issue for low flows

Refs #14

R/app_server.R

@@ -8,4 +8,5 @@ app_server <- function( input, output, session ) {
   con <- DBI::dbConnect(RSQLite::SQLite(), dbname = app_sys("cdf", "Qgen_5000y_unbiased_median.sqlite"))
   # List the first level callModules here
   mod_instant_risk_overview_server("instant_risk_overview", con = con)
+  mod_one_objective_focus_server("one_objective_focus", con = con)
 }

R/calcRiskHeatMap.R

+calcRiskHeatMap <- function(con, ruleset, station, level, lake) {
+  iObjective <- which(objectives$station == station & objectives$level == level)
+  cdfs <- tbl(con, "CDFs")
+  ruleset <- as.character(ruleset)
+  cdf <- cdfs %>% 
+    filter(id_ruleset == {{ ruleset }}, 
+           id_objective == {{ iObjective }},
+           id_lake == {{ lake }}) %>% 
+    collect()
+  cdf$id_cal_day <- as.factor(cdf$id_cal_day)
+  discretStorage <- seq(0, rvgest::lakes[lake, "max"] - rvgest::lakes[lake, "min"], 1) * 1E6
+  listDiscretProbs <- lapply(unique(cdf$id_cal_day), function(x) {
+    dataLength <- length(which(cdf$id_cal_day == x))
+    if(dataLength > 1) {
+      l <- approx(cdf$V[cdf$id_cal_day == x], cdf$prob[cdf$id_cal_day == x], discretStorage, rule = 2)
+      data.frame(day = x, V = l$x, prob = l$y)
+    } else if(dataLength == 1){
+      data.frame(day = x, V = discretStorage, prob = 0)
+    } else {
+      warning("No data for lake", lake, " at ", station, " for objective ", level)
+    }
+  })
+  # if(length(listDiscretProbs) == 365) {
+    return(do.call(rbind, listDiscretProbs))
+  # } else {
+  #   return(NULL)
+  # }
+}
+

R/getRiskHeadMapPlots.R

+getRiskHeadMapPlots <- function(objective) {
+}
\ No newline at end of file

R/mod_one_objective_focus.R

@@ -7,24 +7,90 @@
 #' @noRd 
 #'
 #' @importFrom shiny NS tagList 
+#' @importFrom rvgest objectives
 mod_one_objective_focus_ui <- function(id){
   ns <- NS(id)
+  rulesets <- seq(length(rvgest::rulesets$rules))
+  names(rulesets) <- paste0(rulesets, ". ", rvgest::rulesets$rules)
+  stations <- unique(rvgest::objectives$station)
+  names(stations) <- stations
+  levels <- unique(rvgest::objectives$level)
+  names(levels) <- levels
   tagList(
-    h1("one_objective_focus")
+    selectInput(
+      ns("ruleset"),
+      "Rule set",
+      rulesets,
+      selected = NULL,
+      multiple = FALSE,
+      selectize = TRUE,
+      width = NULL,
+      size = NULL
+    ),
+    selectInput(
+      ns("station"),
+      "Station",
+      stations,
+      selected = NULL,
+      multiple = FALSE,
+      selectize = TRUE,
+      width = NULL,
+      size = NULL
+    ),
+    selectInput(
+      ns("level"),
+      "Flow threshold",
+      levels,
+      selected = NULL,
+      multiple = FALSE,
+      selectize = TRUE,
+      width = NULL,
+      size = NULL
+    ),
+    uiOutput(ns("plots"))
   )
 }
     
-#' one_objective_focus Server Function
+#' one_objective_focus Server Functions
 #'
 #' @noRd 
-mod_one_objective_focus_server <- function(input, output, session){
-  ns <- session$ns
- 
+mod_one_objective_focus_server <- function(id, con){
+  moduleServer( id, function(input, output, session){
+    ns <- session$ns
+    observe({
+      objective <- rvgest::objectives[rvgest::objectives$station == input$station & rvgest::objectives$level == input$level,]
+      indexMonths <- c(1,31,28,31,30,31,30,31,31,30,31,30)
+      labels <- unlist(strsplit("JFMAMJJASOND", NULL))
+      iBreaks <- sapply(seq.int(12), function(i) sum(indexMonths[1:i]))
+      lapply(objective$lakes[[1]]$name, function(lake) {
+        dfDiscretProbs <- calcRiskHeatMap(con, input$ruleset, objective$station, objective$level, lake)
+        if(!is.null(dfDiscretProbs)) {
+          breaks <- sapply(iBreaks, function(x) levels(dfDiscretProbs$day)[x])
+          p <- ggplot(dfDiscretProbs, aes(x = day, y = V / 1e6)) + 
+            geom_tile(aes(fill = prob)) +
+            scale_fill_continuous(low = "green", high = "red", name = "Failure probability") +
+            ggtitle(paste("Lake", lake)) +
+            scale_x_discrete("Calendar days", breaks = breaks, labels = labels) +
+            scale_y_continuous(name="Reservoir storage (hm3)")
+          output[[paste("plot", lake, sep = "_")]] <- renderPlot({p},width = 640, height = 280)
+        }
+      })
+      
+    })
+    
+    output$plots <- renderUI({
+      objective <- rvgest::objectives[rvgest::objectives$station == input$station & rvgest::objectives$level == input$level,]
+      plot_output_list <- lapply(objective$lakes[[1]]$name, function(lake) {
+        plotname <- paste("plot", lake, sep = "_")
+        plotOutput(ns(plotname), height = '250px', inline=TRUE)
+      })
+      do.call(tagList, plot_output_list)
+     })
+  })
 }
     
 ## To be copied in the UI
 # mod_one_objective_focus_ui("one_objective_focus_ui_1")
     
 ## To be copied in the server
-# callModule(mod_one_objective_focus_server, "one_objective_focus_ui_1")
- 
+# mod_one_objective_focus_server("one_objective_focus_ui_1")