Commit 145d5db2 authored by Dorchies David's avatar Dorchies David
Browse files

feat: Annual risk assessment for one objective at one station

- Still color inversion issue for low flows

Refs #14
parent 822aafab
Pipeline #22564 passed with stage
in 3 minutes and 2 seconds
......@@ -8,4 +8,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
mod_instant_risk_overview_server("instant_risk_overview", con = con)
mod_one_objective_focus_server("one_objective_focus", con = con)
}
calcRiskHeatMap <- function(con, ruleset, station, level, lake) {
iObjective <- which(objectives$station == station & objectives$level == level)
cdfs <- tbl(con, "CDFs")
ruleset <- as.character(ruleset)
cdf <- cdfs %>%
filter(id_ruleset == {{ ruleset }},
id_objective == {{ iObjective }},
id_lake == {{ lake }}) %>%
collect()
cdf$id_cal_day <- as.factor(cdf$id_cal_day)
discretStorage <- seq(0, rvgest::lakes[lake, "max"] - rvgest::lakes[lake, "min"], 1) * 1E6
listDiscretProbs <- lapply(unique(cdf$id_cal_day), function(x) {
dataLength <- length(which(cdf$id_cal_day == x))
if(dataLength > 1) {
l <- approx(cdf$V[cdf$id_cal_day == x], cdf$prob[cdf$id_cal_day == x], discretStorage, rule = 2)
data.frame(day = x, V = l$x, prob = l$y)
} else if(dataLength == 1){
data.frame(day = x, V = discretStorage, prob = 0)
} else {
warning("No data for lake", lake, " at ", station, " for objective ", level)
}
})
# if(length(listDiscretProbs) == 365) {
return(do.call(rbind, listDiscretProbs))
# } else {
# return(NULL)
# }
}
getRiskHeadMapPlots <- function(objective) {
}
\ No newline at end of file
......@@ -7,24 +7,90 @@
#' @noRd
#'
#' @importFrom shiny NS tagList
#' @importFrom rvgest objectives
mod_one_objective_focus_ui <- function(id){
ns <- NS(id)
rulesets <- seq(length(rvgest::rulesets$rules))
names(rulesets) <- paste0(rulesets, ". ", rvgest::rulesets$rules)
stations <- unique(rvgest::objectives$station)
names(stations) <- stations
levels <- unique(rvgest::objectives$level)
names(levels) <- levels
tagList(
h1("one_objective_focus")
selectInput(
ns("ruleset"),
"Rule set",
rulesets,
selected = NULL,
multiple = FALSE,
selectize = TRUE,
width = NULL,
size = NULL
),
selectInput(
ns("station"),
"Station",
stations,
selected = NULL,
multiple = FALSE,
selectize = TRUE,
width = NULL,
size = NULL
),
selectInput(
ns("level"),
"Flow threshold",
levels,
selected = NULL,
multiple = FALSE,
selectize = TRUE,
width = NULL,
size = NULL
),
uiOutput(ns("plots"))
)
}
#' one_objective_focus Server Function
#' one_objective_focus Server Functions
#'
#' @noRd
mod_one_objective_focus_server <- function(input, output, session){
ns <- session$ns
mod_one_objective_focus_server <- function(id, con){
moduleServer( id, function(input, output, session){
ns <- session$ns
observe({
objective <- rvgest::objectives[rvgest::objectives$station == input$station & rvgest::objectives$level == input$level,]
indexMonths <- c(1,31,28,31,30,31,30,31,31,30,31,30)
labels <- unlist(strsplit("JFMAMJJASOND", NULL))
iBreaks <- sapply(seq.int(12), function(i) sum(indexMonths[1:i]))
lapply(objective$lakes[[1]]$name, function(lake) {
dfDiscretProbs <- calcRiskHeatMap(con, input$ruleset, objective$station, objective$level, lake)
if(!is.null(dfDiscretProbs)) {
breaks <- sapply(iBreaks, function(x) levels(dfDiscretProbs$day)[x])
p <- ggplot(dfDiscretProbs, aes(x = day, y = V / 1e6)) +
geom_tile(aes(fill = prob)) +
scale_fill_continuous(low = "green", high = "red", name = "Failure probability") +
ggtitle(paste("Lake", lake)) +
scale_x_discrete("Calendar days", breaks = breaks, labels = labels) +
scale_y_continuous(name="Reservoir storage (hm3)")
output[[paste("plot", lake, sep = "_")]] <- renderPlot({p},width = 640, height = 280)
}
})
})
output$plots <- renderUI({
objective <- rvgest::objectives[rvgest::objectives$station == input$station & rvgest::objectives$level == input$level,]
plot_output_list <- lapply(objective$lakes[[1]]$name, function(lake) {
plotname <- paste("plot", lake, sep = "_")
plotOutput(ns(plotname), height = '250px', inline=TRUE)
})
do.call(tagList, plot_output_list)
})
})
}
## To be copied in the UI
# mod_one_objective_focus_ui("one_objective_focus_ui_1")
## To be copied in the server
# callModule(mod_one_objective_focus_server, "one_objective_focus_ui_1")
# mod_one_objective_focus_server("one_objective_focus_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