-
Notifications
You must be signed in to change notification settings - Fork 2
/
approxLeadTimes.R
67 lines (58 loc) · 2.18 KB
/
approxLeadTimes.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
# "`-''-/").___..--''"`-._
# (`6_ 6 ) `-. ( ).`-.__.`) WE ARE ...
# (_Y_.)' ._ ) `._ `. ``-..-' PENN STATE!
# _ ..`--'_..-_/ /--'_.' ,'
# (il),-'' (li),' ((!.-'
#
#
# Author: Weiming Hu (weiming@psu.edu)
# Martina Calovi (mxc895@psu.edu)
#
# Geoinformatics and Earth Observation Laboratory (http://geolab.psu.edu)
# Department of Geography and Institute for CyberScience
# The Pennsylvania State University
#
#' RAnEnExtra::approxLeadTimes
#'
#' RAnEnExtra::approxLeadTimes interpolate forecasts across the lead time dimension.
#'
#' @author Weiming Hu \email{weiming@@psu.edu}
#' @author Martina Calovi \email{mxc895@@psu.edu}
#'
#' @param forecasts A 4-dimensional array
#' @param flt_dimension Which dimension is the lead time dimension.
#' @param old_flts Original forecast lead times in seconds
#' @param new_flts New forecast lead times in seconds
#' @param method The `method` argument passed to `approx`.
#' @param parallel Whether to use `future_apply` for parallelization
#'
#' @md
#' @export
approxLeadTimes <- function(forecasts, flt_dimension, old_flts, new_flts, method = 'linear', parallel = FALSE) {
check.package("R.utils")
check.package("abind")
check.package("progress")
if (parallel) {
check.package('future.apply')
}
# Sanity check
stopifnot(!is.null(dim(forecasts)))
# Figure out the dimensions that I need to loop through
apply_dimensions <- 1:length(dim(forecasts))
apply_dimensions <- apply_dimensions[apply_dimensions != flt_dimension]
# Define a function to downscale along a slice of forecast lead times
func <- function(y, x, xout, method) {
approx(x = x, y = y, xout = xout, method = method)$y
}
# Carry out downscaling along the dimensions
if (parallel) {
forecasts_ds <- future.apply::future_apply(forecasts, apply_dimensions, func, x = old_flts, xout = new_flts, method = method)
} else {
forecasts_ds <- apply(forecasts, apply_dimensions, func, x = old_flts, xout = new_flts, method = method)
}
# Fix the dimensions of downscaled forecasts
perm <- seq_len(length(apply_dimensions)) + 1
perm <- R.utils::insert(perm, flt_dimension, 1)
forecasts_ds <- aperm(forecasts_ds, perm)
return(forecasts_ds)
}