Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
IN-WOP
IRMaRA
Commits
b467d16b
Commit
b467d16b
authored
Apr 24, 2021
by
Dorchies David
Browse files
feat(heatmap): add objective curve
Refs
#14
,
#16
parent
145d5db2
Pipeline
#22570
passed with stage
in 3 minutes and 3 seconds
Changes
6
Pipelines
1
Show whitespace changes
Inline
Side-by-side
R/calcRiskHeatMap.R
View file @
b467d16b
...
@@ -8,20 +8,27 @@ calcRiskHeatMap <- function(con, ruleset, station, level, lake) {
...
@@ -8,20 +8,27 @@ calcRiskHeatMap <- function(con, ruleset, station, level, lake) {
id_lake
==
{{
lake
}})
%>%
id_lake
==
{{
lake
}})
%>%
collect
()
collect
()
cdf
$
id_cal_day
<-
as.factor
(
cdf
$
id_cal_day
)
cdf
$
id_cal_day
<-
as.factor
(
cdf
$
id_cal_day
)
discretStorage
<-
seq
(
0
,
rvgest
::
lakes
[
lake
,
"max"
]
-
rvgest
::
lakes
[
lake
,
"min"
],
1
)
*
1E6
cdf
$
V
<-
cdf
$
V
/
1E6
# -> hm3
listDiscretProbs
<-
lapply
(
unique
(
cdf
$
id_cal_day
),
function
(
x
)
{
if
(
!
objectives
$
flood
[
iObjective
])
cdf
$
prob
<-
1
-
cdf
$
prob
dataLength
<-
length
(
which
(
cdf
$
id_cal_day
==
x
))
discretStorage
<-
seq
(
0
,
rvgest
::
lakes
[
lake
,
"max"
]
-
rvgest
::
lakes
[
lake
,
"min"
],
1
)
caldays
<-
unique
(
cdf
$
id_cal_day
)
listDiscretProbs
<-
lapply
(
seq.int
(
length
(
caldays
)),
function
(
i
)
{
calday
<-
caldays
[
i
]
dataLength
<-
length
(
which
(
cdf
$
id_cal_day
==
calday
))
if
(
dataLength
>
1
)
{
if
(
dataLength
>
1
)
{
l
<-
approx
(
cdf
$
V
[
cdf
$
id_cal_day
==
x
],
cdf
$
prob
[
cdf
$
id_cal_day
==
x
],
discretStorage
,
rule
=
2
)
l
<-
approx
(
cdf
$
V
[
cdf
$
id_cal_day
==
calday
],
cdf
$
prob
[
cdf
$
id_cal_day
==
calday
],
discretStorage
,
rule
=
2
)
data.frame
(
day
=
x
,
V
=
l
$
x
,
prob
=
l
$
y
)
data.frame
(
julian
=
i
,
day
=
calday
,
V
=
l
$
x
,
prob
=
round
(
l
$
y
,
digits
=
1
)
)
}
else
if
(
dataLength
==
1
){
}
else
if
(
dataLength
==
1
){
data.frame
(
day
=
x
,
V
=
discretStorage
,
prob
=
0
)
data.frame
(
julian
=
i
,
day
=
calday
,
V
=
discretStorage
,
prob
=
0
)
}
else
{
}
else
{
warning
(
"No data for lake"
,
lake
,
" at "
,
station
,
" for objective "
,
level
)
warning
(
"No data for lake"
,
lake
,
" at "
,
station
,
" for objective "
,
level
)
}
}
})
})
# if(length(listDiscretProbs) == 365) {
# if(length(listDiscretProbs) == 365) {
return
(
do.call
(
rbind
,
listDiscretProbs
))
df
<-
do.call
(
rbind
,
listDiscretProbs
)
df
$
V
<-
round
(
df
$
V
+
rvgest
::
lakes
[
lake
,
"min"
])
df
$
julian
<-
1
:
nrow
(
df
)
return
(
df
)
# } else {
# } else {
# return(NULL)
# return(NULL)
# }
# }
...
...
R/getObjectiveStorage.R
View file @
b467d16b
...
@@ -3,22 +3,26 @@
...
@@ -3,22 +3,26 @@
#' @param date [Date] (default current date)
#' @param date [Date] (default current date)
#'
#'
#' @return Named [numeric] vector with objective storage for each reservoir
#' @return Named [numeric] vector with objective storage for each reservoir
#' @export
#'
#'
#' @examples
#' @examples
#' getObjectiveStorage()
#' getObjectiveStorage()
getObjectiveStorage
<-
function
(
date
=
Sys.Date
())
{
getObjectiveStorage
<-
function
(
date
=
Sys.Date
())
{
date_julian
<-
which
(
format
(
date
,
"%m%d"
)
==
objectiveStorageCurves
$
day
)
objectiveStorageCurves
[
date_julian
,
-1
]
}
getObjectiveStoragePivots
<-
function
()
{
pivots
<-
list
(
pivots
<-
list
(
data.frame
(
mmdd
=
c
(
'1101'
,
'0201'
,
'0301'
,
'0701'
),
S
=
c
(
24.5
,
84
.
,
130
.
,
170
.
)),
data.frame
(
mmdd
=
c
(
'1108'
,
'1208'
,
'0208'
,
'0408'
,
'0708'
),
S
=
c
(
18.7
,
40
.
,
95
.
,
175
.
,
207.8
)),
data.frame
(
mmdd
=
c
(
'1101'
,
'1231'
,
'0131'
,
'0701'
),
data.frame
(
mmdd
=
c
(
'1101'
,
'1231'
,
'0131'
,
'0701'
),
S
=
c
(
12.3
,
34
.
,
50
.
,
80
.
)),
S
=
c
(
12.3
,
34
.
,
50
.
,
80
.
)),
data.frame
(
mmdd
=
c
(
'1108'
,
'1208'
,
'0208'
,
'0408'
,
'0708'
),
S
=
c
(
18.7
,
40
.
,
95
.
,
175
.
,
207.8
)),
data.frame
(
mmdd
=
c
(
'1101'
,
'0201'
,
'0301'
,
'0701'
),
S
=
c
(
24.5
,
84
.
,
130
.
,
170
.
)),
data.frame
(
mmdd
=
c
(
'1101'
,
'0101'
,
'0201'
,
'0301'
,
'0701'
),
data.frame
(
mmdd
=
c
(
'1101'
,
'0101'
,
'0201'
,
'0301'
,
'0701'
),
S
=
c
(
25
,
100
,
170
,
260
,
350
))
S
=
c
(
25
,
100
,
170
,
260
,
350
))
)
)
names
(
pivots
)
<-
c
(
"AUBE"
,
"SEINE"
,
"YONNE"
,
"MARNE"
)
names
(
pivots
)
<-
rvgest
::
lakes
$
name
caldays
<-
format
(
seq
(
as.Date
(
"2001-01-01"
),
as.Date
(
"2001-12-31"
),
1
),
"%m%d"
)
caldays
<-
format
(
seq
(
as.Date
(
"2001-01-01"
),
as.Date
(
"2001-12-31"
),
1
),
"%m%d"
)
pivots
<-
lapply
(
pivots
,
function
(
x
)
{
pivots
<-
lapply
(
pivots
,
function
(
x
)
{
# sort array by date
# sort array by date
...
@@ -31,9 +35,28 @@ getObjectiveStorage <- function(date = Sys.Date()) {
...
@@ -31,9 +35,28 @@ getObjectiveStorage <- function(date = Sys.Date()) {
x
$
julian
[
nrow
(
x
)]
<-
x
$
julian
[
nrow
(
x
)]
+
365
x
$
julian
[
nrow
(
x
)]
<-
x
$
julian
[
nrow
(
x
)]
+
365
x
x
})
})
date_julian
<-
which
(
format
(
date
,
"%m%d"
)
==
caldays
)
}
unlist
(
lapply
(
pivots
,
function
(
x
)
{
approx
(
x
$
julian
,
x
$
S
,
date_julian
)
$
y
objectiveStoragePivots
<-
getObjectiveStoragePivots
()
getObjectiveStorageCurve
<-
function
(
lake
)
{
caldays
<-
format
(
seq
(
as.Date
(
"2001-01-01"
),
as.Date
(
"2001-12-31"
),
1
),
"%m%d"
)
data.frame
(
day
=
as.factor
(
format
(
seq
(
as.Date
(
"2001-01-01"
),
as.Date
(
"2001-12-31"
),
1
),
"%m%d"
)),
S
=
sapply
(
seq.int
(
365
),
function
(
i
)
{
approx
(
objectiveStoragePivots
[[
lake
]]
$
julian
,
objectiveStoragePivots
[[
lake
]]
$
S
,
i
)
$
y
}))
}))
}
}
getObjectiveStorageCurves
<-
function
()
{
l
<-
lapply
(
rvgest
::
lakes
$
name
,
function
(
lake
)
{
df
<-
getObjectiveStorageCurve
(
lake
)
names
(
df
)[
2
]
<-
lake
df
})
df
<-
do.call
(
cbind
,
l
)
df
<-
df
[,
c
(
1
,
2
*
seq.int
(
nrow
(
rvgest
::
lakes
)))]
df
$
julian
=
seq
(
365
)
return
(
df
)
}
objectiveStorageCurves
<-
getObjectiveStorageCurves
()
R/mod_instant_risk_overview.R
View file @
b467d16b
...
@@ -30,7 +30,7 @@ mod_instant_risk_overview_ui <- function(id){
...
@@ -30,7 +30,7 @@ mod_instant_risk_overview_ui <- function(id){
lapply
(
seq.int
(
nrow
(
rvgest
::
lakes
)),
function
(
i
)
{
lapply
(
seq.int
(
nrow
(
rvgest
::
lakes
)),
function
(
i
)
{
column
(
width
=
3
,
column
(
width
=
3
,
sliderInput
(
ns
(
paste0
(
"V"
,
i
)),
sliderInput
(
ns
(
paste0
(
"V"
,
i
)),
label
=
rvgest
::
lakes
$
name
[
i
],
label
=
paste
(
rvgest
::
lakes
$
name
[
i
],
"lake (hm3)"
),
value
=
round
(
getObjectiveStorage
()[
rvgest
::
lakes
$
name
[
i
]]),
value
=
round
(
getObjectiveStorage
()[
rvgest
::
lakes
$
name
[
i
]]),
min
=
rvgest
::
lakes
$
min
[
i
],
min
=
rvgest
::
lakes
$
min
[
i
],
max
=
rvgest
::
lakes
$
max
[
i
]))
max
=
rvgest
::
lakes
$
max
[
i
]))
...
...
R/mod_one_objective_focus.R
View file @
b467d16b
...
@@ -66,9 +66,12 @@ mod_one_objective_focus_server <- function(id, con){
...
@@ -66,9 +66,12 @@ mod_one_objective_focus_server <- function(id, con){
dfDiscretProbs
<-
calcRiskHeatMap
(
con
,
input
$
ruleset
,
objective
$
station
,
objective
$
level
,
lake
)
dfDiscretProbs
<-
calcRiskHeatMap
(
con
,
input
$
ruleset
,
objective
$
station
,
objective
$
level
,
lake
)
if
(
!
is.null
(
dfDiscretProbs
))
{
if
(
!
is.null
(
dfDiscretProbs
))
{
breaks
<-
sapply
(
iBreaks
,
function
(
x
)
levels
(
dfDiscretProbs
$
day
)[
x
])
breaks
<-
sapply
(
iBreaks
,
function
(
x
)
levels
(
dfDiscretProbs
$
day
)[
x
])
p
<-
ggplot
(
dfDiscretProbs
,
aes
(
x
=
day
,
y
=
V
/
1e6
))
+
objCurve
<-
data.frame
(
day
=
objectiveStorageCurves
$
day
,
V
=
round
(
objectiveStorageCurves
[[
lake
]]))
objCurve
<-
objCurve
[
seq.int
(
1
,
365
,
3
),]
p
<-
ggplot
(
dfDiscretProbs
,
aes
(
x
=
day
,
y
=
V
))
+
geom_tile
(
aes
(
fill
=
prob
))
+
geom_tile
(
aes
(
fill
=
prob
))
+
scale_fill_continuous
(
low
=
"green"
,
high
=
"red"
,
name
=
"Failure probability"
)
+
scale_fill_continuous
(
low
=
"green"
,
high
=
"red"
,
name
=
"Failure probability"
)
+
geom_point
(
data
=
objCurve
,
color
=
"black"
,
size
=
1
,
shape
=
21
,
fill
=
"grey"
)
+
ggtitle
(
paste
(
"Lake"
,
lake
))
+
ggtitle
(
paste
(
"Lake"
,
lake
))
+
scale_x_discrete
(
"Calendar days"
,
breaks
=
breaks
,
labels
=
labels
)
+
scale_x_discrete
(
"Calendar days"
,
breaks
=
breaks
,
labels
=
labels
)
+
scale_y_continuous
(
name
=
"Reservoir storage (hm3)"
)
scale_y_continuous
(
name
=
"Reservoir storage (hm3)"
)
...
...
irmara.Rproj
View file @
b467d16b
...
@@ -12,6 +12,9 @@ Encoding: WINDOWS-1252
...
@@ -12,6 +12,9 @@ Encoding: WINDOWS-1252
RnwWeave: Sweave
RnwWeave: Sweave
LaTeX: pdfLaTeX
LaTeX: pdfLaTeX
AutoAppendNewline: Yes
StripTrailingWhitespace: Yes
BuildType: Package
BuildType: Package
PackageUseDevtools: Yes
PackageUseDevtools: Yes
PackageInstallArgs: --no-multiarch --with-keep.source
PackageInstallArgs: --no-multiarch --with-keep.source
...
...
vignettes/debugging/HeatMap.Rmd
0 → 100644
View file @
b467d16b
---
title: "Untitled"
author: "David Dorchies"
date: "24/04/2021"
output: html_document
---
```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE)
```
# Setup
```{r cars}
library(irmara)
library(ggplot2)
con <- DBI::dbConnect(RSQLite::SQLite(), dbname = irmara:::app_sys("cdf", "Qgen_5000y_unbiased_median.sqlite"))
objectiveStorageCurves <- irmara:::objectiveStorageCurves
```
#
```{r}
ruleset <- 1
iObjective <- 1
objective <- rvgest::objectives[iObjective,]
lake <- objective$lakes[[1]]$name[1]
```
```{r}
objCurve <- data.frame(day = objectiveStorageCurves$day, V = round(objectiveStorageCurves[[lake]]))
objCurve <- objCurve[seq.int(1, 365,3),]
head(objCurve)
```
```{r}
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]))
```
```{r}
dfDiscretProbs <- irmara:::calcRiskHeatMap(con, ruleset, objective$station, objective$level, lake)
breaks <- sapply(iBreaks, function(x) levels(dfDiscretProbs$day)[x])
head(dfDiscretProbs)
```
```{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") +
ggtitle(paste("Lake", lake)) +
scale_x_discrete("Calendar days", breaks = breaks, labels = labels) +
scale_y_continuous(name="Reservoir storage (hm3)")
p
```
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment