diff --git a/DESCRIPTION b/DESCRIPTION index 57564e20cb9d4d35ddd9a3d3a2974ded23c8d9d0..a21b57b1ed11900db7a77365e04a9a054102fdfc 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 d4467de10ef8a75a2573bb7658ddc2c6a0b935cb..018d891fc485a29605032dd79c20e97e118695ab 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 20d69cb365385a205a7ded22e63d82daa875da83..cceb212a4450edc31eca78eb820077cda305a98c 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 2aaafb672915bf835a33f74fb1b668e0ee381688..71b526d5842baa02394a861ce440c6e7baaac01f 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 0000000000000000000000000000000000000000..80e73a0bf02b4d970483a872c2bb84e2607edec7 --- /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 69c76f43742b529a344c6d414d788e62b944bbc0..3084cc573a5e7b2f600af2a2262482f7bb3e7f65 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