Commit 8b08e89e authored by Dorchies David's avatar Dorchies David
Browse files

feat(risk overview): add objective and real time storage

Refs #15
parent b467d16b
Pipeline #22571 passed with stage
in 3 minutes and 21 seconds
......@@ -36,8 +36,8 @@ man/*.Rd
.Rproj.user
# produced vignettes
vignettes/*.html
vignettes/*.pdf
vignettes/*/*.html
vignettes/*/*.pdf
# OAuth2 token, see https://github.com/hadley/httr/releases/tag/v0.3
.httr-oauth
......
......@@ -18,7 +18,9 @@ Imports:
dbplyr,
dplyr,
ggplot2,
rvgest
rvgest,
SGLdataGrabber,
shinyjs
Encoding: UTF-8
LazyData: true
RoxygenNote: 7.1.1
......
......@@ -5,6 +5,7 @@ RUN R -e 'install.packages(c("golem", "processx", "DT", "shinydashboardPlus", "R
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")'
RUN R -e 'remotes::install_gitlab("in-wop/sgldatagrabber@master", host = "gitlab.irstea.fr")'
RUN mkdir /build_zone
ADD . /build_zone
WORKDIR /build_zone
......
#' The application server-side
#'
#' @param input,output,session Internal parameters for {shiny}.
#'
#' @param input,output,session Internal parameters for {shiny}.
#' DO NOT REMOVE.
#' @import shiny
#' @noRd
app_server <- function( input, output, session ) {
con <- DBI::dbConnect(RSQLite::SQLite(), dbname = app_sys("cdf", "Qgen_5000y_unbiased_median.sqlite"))
SGL_RT_storage <- getSGLrealTimeStorage()
# List the first level callModules here
mod_instant_risk_overview_server("instant_risk_overview", con = con)
mod_instant_risk_overview_server("instant_risk_overview", con = con, SGL_RT_storage = SGL_RT_storage)
mod_one_objective_focus_server("one_objective_focus", con = con)
}
......@@ -4,7 +4,7 @@
#' @param ruleset selected rule set of the reservoir
#' @param date date to assess
#' @param storages reservoirs storage at the date to assess in hm3
#' @param n
#' @param n
#'
#' @return a [data.frame] of `n` lines ordered with higher risk first
#' @export
......@@ -14,7 +14,7 @@
#' @examples
#' \dontrun{
#' con <- DBI::dbConnect(
#' RSQLite::SQLite(),
#' 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))
......@@ -23,14 +23,14 @@ calcInstantRisk <- function(con, ruleset, date, storages, n = 10L) {
cdfs <- tbl(con, "CDFs")
mmdd <- format(date, "%m%d")
ruleset <- as.character(ruleset)
cdf <- cdfs %>%
filter(id_ruleset == {{ ruleset }},
id_cal_day == {{ mmdd }}) %>%
cdf <- cdfs %>%
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 %>%
cdf <- cdf %>%
filter(id_objective == {{ i }}, id_lake == {{ lake }})
if(!nrow(cdf) > 0) {
warning("No data for lake ", lake, " at station ", objectives$station[i])
......@@ -49,15 +49,16 @@ calcInstantRisk <- function(con, ruleset, date, storages, n = 10L) {
NULL
}
})
names(l) <- paste(objectives$station, objectives$level, "Q",
ifelse(objectives$flood, "<", ">"),
names(l) <- paste(objectives$station, objectives$level, "Q",
ifelse(objectives$flood, "<", ">"),
objectives$threshold, "m3/s")
df <- 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$prob[!df$flood] <- 1 - df$prob[!df$flood]
df <- df[!is.na(df$prob),]
df <- head(df[order(df$prob, decreasing = TRUE),], n)
return(df)
......
......@@ -8,7 +8,7 @@
#' getObjectiveStorage()
getObjectiveStorage <- function(date = Sys.Date()) {
date_julian <- which(format(date, "%m%d") == objectiveStorageCurves$day)
objectiveStorageCurves[date_julian, -1]
unlist(objectiveStorageCurves[date_julian, -1])
}
getObjectiveStoragePivots <- function() {
......@@ -55,7 +55,6 @@ getObjectiveStorageCurves <- function() {
})
df <- do.call(cbind, l)
df <- df[, c(1, 2 * seq.int(nrow(rvgest::lakes)))]
df$julian = seq(365)
return(df)
}
......
getSGLrealTimeStorage <- function() {
df <- SGLdataGrabber::SGL_GrabAllVariables()$Data
colLakesStorage <- c("Pann5", "Seine6", "Aube16", "Marne6")
names(colLakesStorage) <- rvgest::lakes$name
df <- df[df$id %in% colLakesStorage,]
lV <- lapply(colLakesStorage,
function(x) {
df$value[df$id == x]
})
cbind(datetime = as.POSIXct(df$datetime[df$id == colLakesStorage[1]]), do.call(cbind, lV))
}
......@@ -7,11 +7,13 @@
#' @noRd
#'
#' @importFrom shiny NS tagList
#' @importFrom shinyjs useShinyjs
mod_instant_risk_overview_ui <- function(id){
ns <- NS(id)
choices <- seq(length(rvgest::rulesets$rules))
names(choices) <- paste0(choices, ". ", rvgest::rulesets$rules)
tagList(
useShinyjs(),
fluidRow(
column(width = 6,
selectInput(
......@@ -26,6 +28,17 @@ mod_instant_risk_overview_ui <- function(id){
)),
column(width = 6,
dateInput(ns("date"), "Date:", value = Sys.Date()))),
fluidRow(
column(width = 8,
radioButtons(ns("radio_mode_select"),
"Reservoir storage mode",
c("manual" = "manual",
"objective curve" = "objective",
"real time value" = "RT"),
selected = "RT",
inline=T),
offset = 2)
),
fluidRow(
lapply(seq.int(nrow(rvgest::lakes)), function(i) {
column(width = 3,
......@@ -46,10 +59,35 @@ mod_instant_risk_overview_ui <- function(id){
#'
#' @noRd
#' @import ggplot2
mod_instant_risk_overview_server <- function(id, con) {
mod_instant_risk_overview_server <- function(id, con, SGL_RT_storage) {
moduleServer(id, function(input, output, session){
ns <- session$ns
observeEvent({
input$radio_mode_select
input$date
}, {
if(input$radio_mode_select == "manual") {
fAction <- shinyjs::enable
} else {
fAction <- shinyjs::disable
if(input$radio_mode_select == "objective") {
V <- round(getObjectiveStorage(input$date))
} else {
# Real time storage
iDate <- as.numeric(as.POSIXct(input$date))
timeDeviation <- abs(SGL_RT_storage[,1] - iDate)
i <- which(timeDeviation == min(timeDeviation))
V <- SGL_RT_storage[i, -1]
}
attr(V, "names") <- NULL # Otherwise we pass an object to javascript...
lapply(seq.int(4), function(i) {
updateSliderInput(session, inputId = paste0("V", i), value = V[i])
})
}
lapply(paste0("V", seq.int(4)), fAction)
})
df <- reactive({
storages <- c(input$V1, input$V2, input$V3, input$V4)
names(storages) <- lakes$name
......
---
title: "Grabbing real time data from SGL"
output: html_notebook
---
```{r}
library(Rthingsboard)
```
```{r}
url = "http://scada.g-eau.fr"
entityId = "819c97b0-b6c4-11ea-a032-371cab4fbc33"
publicId = "87f58040-b6c4-11ea-a032-371cab4fbc33"
startDate = as.POSIXct("2020-05-01 14:00:00")
endDate = as.POSIXct("2020-06-01 14:00:00")
keys <- c("Pann5", "Seine6", "Aube16", "Marne6")
# Set logger threshold to DEBUG to see extra messages for debug purpose
logger::log_threshold(logger::DEBUG)
```
```{r}
tb_api = ThingsboardApi(url = url, publicId = publicId)
```
```{r}
available_keys = tb_api$getKeys(entityId = entityId)
```
```{r}
lV <- lapply(keys, function(key) {
tb_api$getTelemetry(entityId,
keys = key,
startTs = startDate,
endTs = endDate)
})
```
```{r}
```
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