feat(instant risk): first plot but still not interactive

Refs #2, #15

DESCRIPTION

@@ -14,7 +14,9 @@ Imports:
     glue,
     htmltools,
     shinydashboard,
-    shinydashboardPlus
+    shinydashboardPlus,
+    RSQLite,
+    dbplyr
 Encoding: UTF-8
 LazyData: true
 RoxygenNote: 7.1.1

Dockerfile

 FROM rocker/r-ver:4.0.3
 RUN apt-get update && apt-get install -y  git-core libcurl4-openssl-dev libgit2-dev libicu-dev libssl-dev libxml2-dev make pandoc pandoc-citeproc zlib1g-dev && rm -rf /var/lib/apt/lists/*
 RUN echo "options(repos = c(CRAN = 'https://cran.rstudio.com/'), download.file.method = 'libcurl')" >> /usr/local/lib/R/etc/Rprofile.site
-RUN R -e 'install.packages(c("golem", "processx", "DT", "shinydashboardPlus"))'
+RUN R -e 'install.packages(c("golem", "processx", "DT", "shinydashboardPlus", "RSQLite", "dbplyr"))'
 RUN R -e 'install.packages(c("lubridate", "TSstudio"))'
 ARG COMMIT_HASH=unknown
 RUN R -e 'remotes::install_gitlab("in-wop/rvgest@master", host = "gitlab.irstea.fr")'

R/app_server.R

@@ -5,6 +5,7 @@
 #' @import shiny
 #' @noRd
 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
-
+  callModule(mod_instant_risk_overview_server, "instant_risk_overview_ui_1", con = con)
 }

R/app_ui.R

@@ -25,7 +25,7 @@ app_ui <- function(request) {
       # Show the appropriate tab's content in the main body of our dashboard when we select it
       body = shinydashboard::dashboardBody(
         shinydashboard::tabItems(
-          shinydashboard::tabItem("instant_risk_overview", mod_instant_risk_overview_ui("Home_ui_1")),
+          shinydashboard::tabItem("instant_risk_overview", mod_instant_risk_overview_ui("instant_risk_overview_ui_1")),
           shinydashboard::tabItem("one_objective_focus", mod_one_objective_focus_ui("MuscleGroup_ui_1")),
           shinydashboard::tabItem("ruleset_comparison", mod_ruleset_comparison_ui("Exercises_ui_1")
           )

R/calcInstantRisk.R

+#' Calculation of instant risk for all objectives
+#'
+#' @param con Connection to risk database
+#' @param ruleset selected rule set of the reservoir
+#' @param date date to assess
+#' @param storages reservoirs storage at the date to assess
+#'
+#' @return
+#' @export
+#' @import dplyr
+#' @importFrom rvgest objectives lakes
+#'
+#' @examples
+#' \dontrun{
+#' con <- DBI::dbConnect(
+#'   RSQLite::SQLite(), 
+#'   dbname = system.file("cdf", "Qgen_5000y_unbiased_median.sqlite", package = "irmara")
+#' )
+#' calcInstantRisk(con, 1, Sys.Date(), c(AUBE = 100, YONNE = 50, SEINE = 130, MARNE = 250))
+#' }
+calcInstantRisk <- function(con, ruleset, date, storages) {
+  cdfs <- tbl(con, "CDFs")
+  mmdd <- format(date, "%m%d")
+  ruleset <- as.character(ruleset)
+  cdf <- cdfs %>% 
+    filter(id_ruleset == {{ ruleset }}, 
+                  id_cal_day == {{ mmdd }}) %>% 
+    collect()
+  l <- lapply(seq.int(nrow(objectives)), function(i) {
+    probs <- sapply(objectives$lakes[i][[1]]$name, function(lake) {
+      cdf <- cdf %>% 
+        filter(id_objective == {{ i }}, id_lake == {{ lake }})
+      if(!nrow(cdf) > 0) {
+        warning("No data for lake ", lake, " at station ", objectives$station[i])
+        NULL
+      } else {
+        iLake <- which(lakes$name == lake)
+        approx(cdf$V, cdf$prob, storages[lake]- lakes$min[iLake])$y * (lakes$max[iLake] - lakes$min[iLake])
+      }
+    })
+    probs <- unlist(Filter(Negate(is.null), probs))
+    if(length(probs) > 0) {
+      iLakes <- match(objectives$lakes[i][[1]]$name, lakes$name)
+      totalCapacity <- sum(lakes$max[iLakes] - lakes$min[iLakes])
+      sum(probs) / sum(totalCapacity)
+    } else {
+      NULL
+    }
+  })
+  names(l) <- paste(objectives$station, objectives$level, "Q", 
+                    ifelse(objectives$flood, "<", ">"), 
+                    objectives$threshold, "m3/s")
+  data.frame(id_objective = seq.int(nrow(objectives)), 
+             objective = names(l),
+             station = objectives$station,
+             flood = objectives$flood,
+             level = objectives$level,
+             prob = sapply(l, function(x) {ifelse(is.null(x), NA, x)}))
+}

R/mod_instant_risk_overview.R

@@ -7,10 +7,11 @@
 #' @noRd 
 #'
 #' @importFrom shiny NS tagList 
+#' @importFrom rvgest lakes rulesets
 mod_instant_risk_overview_ui <- function(id){
   ns <- NS(id)
-  choices <- seq(length(rvgest::rulesets$rules))
-  names(choices) <- paste0(choices, ". ", rvgest::rulesets$rules)
+  choices <- seq(length(rulesets$rules))
+  names(choices) <- paste0(choices, ". ", rulesets$rules)
   tagList(
     selectInput(
       "ruleset",
@@ -23,22 +24,42 @@ mod_instant_risk_overview_ui <- function(id){
       size = NULL
     ),
     dateInput("date", "Date:", value = Sys.Date()),
-    lapply(seq(nrow(rvgest::lakes)), function(i) {
+    lapply(seq.int(nrow(lakes)), function(i) {
       numericInput(paste0("V", i),
-                   rvgest::lakes$name[i],
-                   round(getObjectiveStorage()[rvgest::lakes$name[i]]),
-                   min = rvgest::lakes$min[i],
-                   max = rvgest::lakes$max[i])
-    })
+                   lakes$name[i],
+                   round(getObjectiveStorage()[lakes$name[i]]),
+                   min = lakes$min[i],
+                   max = lakes$max[i])
+    }),
+    # tableOutput(ns("table"))
+    plotOutput(ns("plot"))
   )
+  
 }
     
 #' instant_risk_overview Server Function
 #'
 #' @noRd 
-mod_instant_risk_overview_server <- function(input, output, session){
+#' @import ggplot2
+mod_instant_risk_overview_server <- function(input, output, session, con){
   ns <- session$ns
- 
+  
+  df <- reactive({
+    df <- calcInstantRisk(con, 1, Sys.Date(), getObjectiveStorage())
+    storages <- c(input$v1, input$v2, input$v3, input$v4)
+    if(!is.null(unlist(storages))) {
+      names(storages) <- lakes$name
+      print(storage)
+      df <- calcInstantRisk(con, input$ruleset, input$date, storages)
+    }
+    df <- head(df[order(df$prob, decreasing = TRUE),], 10)
+    df
+  })
+  # output$table <- renderTable(df())
+  output$plot <- renderPlot(
+    ggplot(df(), aes(x = objective, y = prob)) +
+      geom_col(aes(fill = level)) +
+      coord_flip())
 }
     
 ## To be copied in the UI