Commit 137d23f1 authored by Dorchies David's avatar Dorchies David
Browse files

feat: add real time curve on heatmaps

Refs #14
parent 1f21ff5d
Pipeline #22649 failed with stage
in 1 minute and 13 seconds
......@@ -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)
}
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")))
}
......@@ -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)")
......
......@@ -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)")
......
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