getObjectiveStorage.R 2.1 KB
Newer Older
1
2
3
4
5
6
7
8
9
#' Interpolate objective reservoir storage for a given date
#'
#' @param date [Date] (default current date)
#'
#' @return Named [numeric] vector with objective storage for each reservoir
#'
#' @examples
#' getObjectiveStorage()
getObjectiveStorage <- function(date = Sys.Date()) {
10
11
12
13
14
  date_julian <- which(format(date, "%m%d") == objectiveStorageCurves$day)
  objectiveStorageCurves[date_julian, -1]
}

getObjectiveStoragePivots <- function() {
15
16
17
  pivots <- list(
    data.frame(mmdd = c('1101', '1231', '0131', '0701'),
               S = c(12.3, 34., 50., 80.)),
18
19
20
21
    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.)),
22
23
24
    data.frame(mmdd = c('1101', '0101', '0201', '0301', '0701'),
               S = c(25, 100, 170, 260, 350))
  )
25
  names(pivots) <- rvgest::lakes$name
26
27
28
29
30
31
32
33
34
35
36
37
38
39
  caldays <- format(seq(as.Date("2001-01-01"), as.Date("2001-12-31"), 1), "%m%d")
  pivots <- lapply(pivots, function(x) {
    # sort array by date
    x <- x[order(x$mmdd),]
    # add count for before and after year
    x <- rbind(x[nrow(x),], x, x[1,])
    # Julian day count
    x$julian <- match(x$mmdd, caldays)
    x$julian[1] <- x$julian[1] - 365
    x$julian[nrow(x)] <- x$julian[nrow(x)] + 365
    x
  })
}

40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
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()