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

feat(instant risk): plot with interactivity!

Refs #15
parent f14b94d0
Pipeline #22526 passed with stage
in 3 minutes and 9 seconds
......@@ -7,5 +7,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
callModule(mod_instant_risk_overview_server, "instant_risk_overview_ui_1", con = con)
mod_instant_risk_overview_server("instant_risk_overview", con = con)
}
......@@ -25,9 +25,9 @@ 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("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")
shinydashboard::tabItem("instant_risk_overview", mod_instant_risk_overview_ui("instant_risk_overview")),
shinydashboard::tabItem("one_objective_focus", mod_one_objective_focus_ui("one_objective_focus")),
shinydashboard::tabItem("ruleset_comparison", mod_ruleset_comparison_ui("ruleset_comparison")
)
)
),
......
......@@ -3,9 +3,10 @@
#' @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
#' @param storages reservoirs storage at the date to assess in hm3
#' @param n
#'
#' @return
#' @return a [data.frame] of `n` lines ordered with higher risk first
#' @export
#' @import dplyr
#' @importFrom rvgest objectives lakes
......@@ -18,7 +19,7 @@
#' )
#' calcInstantRisk(con, 1, Sys.Date(), c(AUBE = 100, YONNE = 50, SEINE = 130, MARNE = 250))
#' }
calcInstantRisk <- function(con, ruleset, date, storages) {
calcInstantRisk <- function(con, ruleset, date, storages, n = 10L) {
cdfs <- tbl(con, "CDFs")
mmdd <- format(date, "%m%d")
ruleset <- as.character(ruleset)
......@@ -26,6 +27,7 @@ calcInstantRisk <- function(con, ruleset, date, storages) {
filter(id_ruleset == {{ ruleset }},
id_cal_day == {{ mmdd }}) %>%
collect()
storages <- storages * 1E6 # Conversion hm3->m3
l <- lapply(seq.int(nrow(objectives)), function(i) {
probs <- sapply(objectives$lakes[i][[1]]$name, function(lake) {
cdf <- cdf %>%
......@@ -50,10 +52,13 @@ calcInstantRisk <- function(con, ruleset, date, storages) {
names(l) <- paste(objectives$station, objectives$level, "Q",
ifelse(objectives$flood, "<", ">"),
objectives$threshold, "m3/s")
data.frame(id_objective = seq.int(nrow(objectives)),
df <- 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)}))
df <- df[!is.na(df$prob),]
df <- head(df[order(df$prob, decreasing = TRUE),], n)
return(df)
}
......@@ -13,24 +13,30 @@ mod_instant_risk_overview_ui <- function(id){
choices <- seq(length(rulesets$rules))
names(choices) <- paste0(choices, ". ", rulesets$rules)
tagList(
selectInput(
"ruleset",
"Rule set",
choices,
selected = NULL,
multiple = FALSE,
selectize = TRUE,
width = NULL,
size = NULL
fluidRow(
column(width = 6,
selectInput(
ns("ruleset"),
"Rule set",
choices,
selected = NULL,
multiple = FALSE,
selectize = TRUE,
width = NULL,
size = NULL
)),
column(width = 6,
dateInput(ns("date"), "Date:", value = Sys.Date()))),
fluidRow(
lapply(seq.int(nrow(lakes)), function(i) {
column(width = 3,
numericInput(ns(paste0("V", i)),
lakes$name[i],
round(getObjectiveStorage()[lakes$name[i]]),
min = lakes$min[i],
max = lakes$max[i]))
})
),
dateInput("date", "Date:", value = Sys.Date()),
lapply(seq.int(nrow(lakes)), function(i) {
numericInput(paste0("V", i),
lakes$name[i],
round(getObjectiveStorage()[lakes$name[i]]),
min = lakes$min[i],
max = lakes$max[i])
}),
# tableOutput(ns("table"))
plotOutput(ns("plot"))
)
......@@ -41,30 +47,41 @@ mod_instant_risk_overview_ui <- function(id){
#'
#' @noRd
#' @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))) {
mod_instant_risk_overview_server <- function(id, con) {
moduleServer(id, function(input, output, session){
ns <- session$ns
# observeEvent(input$compute,{
# browser()
# storages <- c(input$v1, input$v2, input$v3, input$v4)
# names(storages) <- lakes$name
# print(storage)
# df <- calcInstantRisk(con, input$ruleset, input$date, storages)
# df <- head(df[order(df$prob, decreasing = TRUE),], 10)
# output$plot <- renderPlot(
# ggplot(df(), aes(x = objective, y = prob)) +
# geom_col(aes(fill = level)) +
# coord_flip())
# })
df <- reactive({
storages <- c(input$V1, input$V2, input$V3, input$V4)
names(storages) <- lakes$name
print(storage)
df <- calcInstantRisk(con, input$ruleset, input$date, storages)
}
df <- head(df[order(df$prob, decreasing = TRUE),], 10)
df
golem::print_dev(storages)
calcInstantRisk(con, input$ruleset, input$date, storages)
})
# output$table <- renderTable(df())
output$plot <- renderPlot(
ggplot(df(), aes(x = reorder(objective, prob), y = prob)) +
geom_col(aes(fill = level)) +
scale_y_continuous(labels = scales::percent_format(accuracy = 1)) +
coord_flip())
})
# 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
# mod_instant_risk_overview_ui("instant_risk_overview_ui_1")
## To be copied in the server
# callModule(mod_instant_risk_overview_server, "instant_risk_overview_ui_1")
# mod_instant_risk_overview_server("instant_risk_overview_ui_1")
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