From f14b94d0aac060fdcf54165df56290fd65db2b01 Mon Sep 17 00:00:00 2001
From: Dorchies David <david.dorchies@inrae.fr>
Date: Fri, 2 Apr 2021 15:02:02 +0200
Subject: [PATCH] feat(instant risk): first plot but still not interactive
Refs #2, #15
---
DESCRIPTION | 4 ++-
Dockerfile | 2 +-
R/app_server.R | 3 +-
R/app_ui.R | 2 +-
R/calcInstantRisk.R | 59 +++++++++++++++++++++++++++++++++++
R/mod_instant_risk_overview.R | 41 ++++++++++++++++++------
6 files changed, 97 insertions(+), 14 deletions(-)
create mode 100644 R/calcInstantRisk.R
diff --git a/DESCRIPTION b/DESCRIPTION
index 57564e2..a21b57b 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -14,7 +14,9 @@ Imports:
glue,
htmltools,
shinydashboard,
- shinydashboardPlus
+ shinydashboardPlus,
+ RSQLite,
+ dbplyr
Encoding: UTF-8
LazyData: true
RoxygenNote: 7.1.1
diff --git a/Dockerfile b/Dockerfile
index d4467de..018d891 100644
--- a/Dockerfile
+++ b/Dockerfile
@@ -1,7 +1,7 @@
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")'
diff --git a/R/app_server.R b/R/app_server.R
index 20d69cb..cceb212 100644
--- a/R/app_server.R
+++ b/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)
}
diff --git a/R/app_ui.R b/R/app_ui.R
index 2aaafb6..71b526d 100644
--- a/R/app_ui.R
+++ b/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")
)
diff --git a/R/calcInstantRisk.R b/R/calcInstantRisk.R
new file mode 100644
index 0000000..80e73a0
--- /dev/null
+++ b/R/calcInstantRisk.R
@@ -0,0 +1,59 @@
+#' 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)}))
+}
diff --git a/R/mod_instant_risk_overview.R b/R/mod_instant_risk_overview.R
index 69c76f4..3084cc5 100644
--- a/R/mod_instant_risk_overview.R
+++ b/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
--
GitLab