From 137d23f1559a06b181683bb64fbfb34a73565ecb Mon Sep 17 00:00:00 2001
From: Dorchies David <david.dorchies@inrae.fr>
Date: Mon, 26 Apr 2021 18:31:02 +0200
Subject: [PATCH] feat: add real time curve on heatmaps
Refs #14
---
R/app_server.R | 2 +-
R/getCurves.R | 12 ++++++++++++
R/mod_one_objective_focus.R | 13 ++++++++-----
vignettes/debugging/HeatMap.Rmd | 20 +++++++++++++++++++-
4 files changed, 40 insertions(+), 7 deletions(-)
create mode 100644 R/getCurves.R
diff --git a/R/app_server.R b/R/app_server.R
index f03730f..ad5fa1a 100644
--- a/R/app_server.R
+++ b/R/app_server.R
@@ -9,5 +9,5 @@ app_server <- function( input, output, session ) {
SGL_RT_storage <- getSGLrealTimeStorage()
# List the first level callModules here
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)
+ mod_one_objective_focus_server("one_objective_focus", con = con, SGL_RT_storage = SGL_RT_storage)
}
diff --git a/R/getCurves.R b/R/getCurves.R
new file mode 100644
index 0000000..93cfc16
--- /dev/null
+++ b/R/getCurves.R
@@ -0,0 +1,12 @@
+getCurves <- function(SGL_RT_storage, lake) {
+ objCurve <- data.frame(day = objectiveStorageCurves$day, V = round(objectiveStorageCurves[[lake]]))
+ objCurve <- objCurve[seq.int(1, 365,3),]
+
+ RTcurve <- data.frame(
+ day = as.factor(format(as.POSIXct(SGL_RT_storage[,"datetime"], origin="1970-01-01"), "%m%d")),
+ V = SGL_RT_storage[, lake]
+ )
+
+ return(rbind(cbind(objCurve, type = "objective"),
+ cbind(RTcurve, type = "real time")))
+}
diff --git a/R/mod_one_objective_focus.R b/R/mod_one_objective_focus.R
index 93e1268..a42dbfe 100644
--- a/R/mod_one_objective_focus.R
+++ b/R/mod_one_objective_focus.R
@@ -55,7 +55,7 @@ mod_one_objective_focus_ui <- function(id){
#'
#' @noRd
#' @importFrom scales percent
-mod_one_objective_focus_server <- function(id, con){
+mod_one_objective_focus_server <- function(id, con, SGL_RT_storage){
moduleServer( id, function(input, output, session){
ns <- session$ns
observe({
@@ -67,12 +67,15 @@ mod_one_objective_focus_server <- function(id, con){
dfDiscretProbs <- calcRiskHeatMap(con, input$ruleset, objective$station, objective$level, lake)
if(!is.null(dfDiscretProbs)) {
breaks <- sapply(iBreaks, function(x) levels(dfDiscretProbs$day)[x])
- objCurve <- data.frame(day = objectiveStorageCurves$day, V = round(objectiveStorageCurves[[lake]]))
- objCurve <- objCurve[seq.int(1, 365,3),]
+ Curves <- getCurves(SGL_RT_storage, lake)
p <- ggplot(dfDiscretProbs, aes(x = day, y = V)) +
geom_tile(aes(fill = prob)) +
- scale_fill_continuous(low = "green", high = "red", name = "Failure probability", labels = percent) +
- geom_point(data = objCurve, color = "black", size = 1, shape = 21, fill = "grey") +
+ scale_fill_continuous(low = "green", high = "red", name = "Failure probability") +
+ geom_point(data = Curves,
+ aes(x = day, y = V, color = type),
+ size = 1, shape = 21, fill = "#275662") +
+ scale_color_manual(name = "Filling curve",
+ values = c("objective" = "#797870", "real time" = "black")) +
ggtitle(paste("Lake", lake)) +
scale_x_discrete("Calendar days", breaks = breaks, labels = labels) +
scale_y_continuous(name="Reservoir storage (hm3)")
diff --git a/vignettes/debugging/HeatMap.Rmd b/vignettes/debugging/HeatMap.Rmd
index bb9fd52..dd1f4eb 100644
--- a/vignettes/debugging/HeatMap.Rmd
+++ b/vignettes/debugging/HeatMap.Rmd
@@ -46,11 +46,29 @@ breaks <- sapply(iBreaks, function(x) levels(dfDiscretProbs$day)[x])
head(dfDiscretProbs)
```
+```{r}
+SGL_RT_storage <- irmara:::getSGLrealTimeStorage()
+RTcurve <- data.frame(
+ day = as.factor(format(as.POSIXct(SGL_RT_storage[,"datetime"], origin="1970-01-01"), "%m%d")),
+ V = SGL_RT_storage[, lake]
+)
+```
+
+```{r}
+Curves <- rbind(cbind(objCurve, type = "objective"),
+ cbind(RTcurve, type = "real time"))
+```
+
+
+
```{r}
p <- ggplot(dfDiscretProbs, aes(x = day, y = V)) +
geom_tile(aes(fill = prob)) +
scale_fill_continuous(low = "green", high = "red", name = "Failure probability") +
- geom_point(data = objCurve, color = "black", size = 1, shape = 21, fill = "grey") +
+ geom_point(data = Curves, aes(x = day, y = V, color = type), size = 1, shape = 21, fill = "#275662") +
+ scale_color_manual(
+ name = "Filling curve",
+ values = c("objective" = "#797870", "real time" = "black")) +
ggtitle(paste("Lake", lake)) +
scale_x_discrete("Calendar days", breaks = breaks, labels = labels) +
scale_y_continuous(name="Reservoir storage (hm3)")
--
GitLab