Commit f14b94d0 authored by Dorchies David's avatar Dorchies David
Browse files

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

Refs #2, #15
parent 281e373c
Pipeline #21975 passed with stage
in 31 minutes and 36 seconds
......@@ -14,7 +14,9 @@ Imports:
glue,
htmltools,
shinydashboard,
shinydashboardPlus
shinydashboardPlus,
RSQLite,
dbplyr
Encoding: UTF-8
LazyData: true
RoxygenNote: 7.1.1
......
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")'
......
......@@ -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)
}
......@@ -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")
)
......
#' 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)}))
}
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment