calcRiskHeatMap.R 1.4 KB
Newer Older
1
2
3
4
calcRiskHeatMap <- function(con, ruleset, station, level, lake) {
  iObjective <- which(objectives$station == station & objectives$level == level)
  cdfs <- tbl(con, "CDFs")
  ruleset <- as.character(ruleset)
5
6
  cdf <- cdfs %>%
    filter(id_ruleset == {{ ruleset }},
7
           id_objective == {{ iObjective }},
8
           id_lake == {{ lake }}) %>%
9
10
    collect()
  cdf$id_cal_day <- as.factor(cdf$id_cal_day)
11
12
13
14
15
16
17
  cdf$V <- cdf$V / 1E6 # -> hm3
  if(!objectives$flood[iObjective]) cdf$prob <- 1 - cdf$prob
  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))
18
    if(dataLength > 1) {
19
20
      l <- approx(cdf$V[cdf$id_cal_day == calday], cdf$prob[cdf$id_cal_day == calday], discretStorage, rule = 2)
      data.frame(julian = i, day = calday, V = l$x, prob = round(l$y, digits = 1))
21
    } else if(dataLength == 1){
22
      data.frame(julian = i, day = calday, V = discretStorage, prob = 0)
23
24
25
26
27
    } else {
      warning("No data for lake", lake, " at ", station, " for objective ", level)
    }
  })
  # if(length(listDiscretProbs) == 365) {
28
29
30
31
    df <- do.call(rbind, listDiscretProbs)
    df$V <- round(df$V + rvgest::lakes[lake, "min"])
    df$julian <- 1:nrow(df)
    return(df)
32
33
34
35
36
  # } else {
  #   return(NULL)
  # }
}