R/get_relative_values.R

In DUToolkit: Visualizing and Quantifying Decision Uncertainty

#' Find output values at time points relative to the peak (or minimum)
#'
#' @description For each policy alternative, this function finds the the model
#' output values for each simulation run at the specified time points relative
#' to the peak (or minimum) value.
#'
#' @param data A list of data.frames (one data.frame for each policy
#' alternative).
#'
#' @section data format:
#' Each data.frame in `data` contains the results from multiple model
#' runs using different parameter sets (e.g., from probabilistic sensitivity,
#' uncertainty, or Bayesian inference analysis). The first column contains
#' the model time and subsequent columns contain the predicted output for
#' each simulation run at the respective time.
#' The model time in the first column must contain numeric values indicating
#' a simulation time (ex. 1, 2, 3,...) or dates (ex. "2021-01-01", "2021-01-02")
#' which must be in `R` Date format (i.e., class="Date"). To ensure a consistent
#' basis for comparison, the model time in the first column should be the same for
#' each policy alternative (data.frame).
#'
#' @param max_min_values_list A list generated by [get_max_min_values()].
#' @param t_s The total time window to examine before and after the
#' peak (or minimum) value.
#' @param t_ss The interval size for sampling time points within the specified
#' time window `t_s`. For example, if `t_s = 20` and `t_ss = 10` the function will extract values at
#' peak_time-20, peak_time-10, peak_time, peak_time+10, peak_time+20.
#' @param Dt_max A logical value indicating whether the decision threshold
#' is a maximum (`TRUE`) or a minimum (`FALSE`). The default is `TRUE`.
#'
#' @return A list of nested lists with the following elements:
#' (i) a data.frame of values recorded at specific time steps relative to the
#' peak time (e.g., peak-10, peak, peak+10) for each model run, and (ii) a
#' vector of the names of each time step ex. minus_30,minus_20,...,plus_20, plus_30.
#' @export
#'
#' @examples
#' tmin <- "2021-01-01"
#' tmax <- "2021-04-10"
#' D <- 750
#' t_s <- 20
#' t_ss <- 10
#'
#' peak_values_list <- get_max_min_values(
#'   psa_data,
#'   tmin = tmin,
#'   tmax = tmax,
#'   Dt_max = TRUE
#' )
#'
#' peak_temporal_list <- get_relative_values(
#'   psa_data,
#'   peak_values_list,
#'   t_s = t_s,
#'   t_ss = t_ss
#' )
get_relative_values <- function(
    data,
    max_min_values_list,
    t_s,
    t_ss,
    Dt_max = TRUE) {
  if (inherits(data, "list")) {
    if (length(data) == length(max_min_values_list)) {
      data_set <- vector(mode = "list", length = length(data))
      names(data_set) <- names(data)
      for (i in 1:length(data)) {
        data_set[[i]] <- get_relative_values_1(data[[i]], max_min_values_list[[i]], t_s, t_ss, Dt_max)
      }
    } else {
      rlang::abort("The list of model output data.frames and the list of peak values
                   data.frames must be the same length.",
        class = "data_length"
      )
    }
  } else if (inherits(data, "data.frame")) {
    data_set <- get_relative_values_1(data, max_min_values_list, t_s, t_ss, Dt_max)
  } else {
    rlang::abort("The first argument is not a data.frame or list of data.frames",
      class = "data_type"
    )
  }
  return(data_set)
}

#' Finds  the model output values for each simulation run at the specified time
#' points relative to the peak (or minimum) value for a single set of simulations
#'
#' @inheritParams get_relative_values
#' @noRd
#' @return A lists with the following two elements:
#' (i) a dataframe of values at each timestep from peak across all model runs, and (ii)
#' a vector of the names of each time step ex. minus_30, minus_20,...,plus_20, plus_30
get_relative_values_1 <- function(
    data,
    max_min_values_list,
    t_s,
    t_ss,
    Dt_max = TRUE) {
  if (!inherits(data[, 1], "Date") && !inherits(data[, 1], "numeric") &&
    !inherits(data[, 1], "integer")) {
    rlang::abort("The first column of the data.frame must be a Date or a numeric value.",
      class = "date_type"
    )
  }
  type <- ifelse(Dt_max, "peak", "minimum")
  peak_temporal <- data.frame(
    time = c(rep(type, length(max_min_values_list[, 1]))),
    outcome = c(max_min_values_list[, 2]),
    N = max_min_values_list[, 1]
  )
  lev <- c(type)
  for (j in seq(t_ss, t_s, t_ss)) {
    temp_m <- temp_p <- sim <- c()
    for (i in 1:length(max_min_values_list[, 1])) {
      minus <- ifelse((max_min_values_list[i, 3] - j) > 0,
        data[match((max_min_values_list[i, 3] - j), data[, 1]), i + 1],
        NA
      )
      temp_m <- append(temp_m, minus)
      temp_p <- append(temp_p, data[
        match(
          (max_min_values_list[i, 3] + j),
          data[, 1]
        ),
        i + 1
      ])
      sim <- append(sim, max_min_values_list[i, 1])
    }
    peak_temporal <- rbind(
      peak_temporal,
      data.frame(time = c(rep(paste(type, "-", j, sep = ""), length(temp_m))),
                 outcome = temp_m, N = sim),
      data.frame(time = c(rep(paste(type, "+", j, sep = ""), length(temp_p))),
                 outcome = temp_p, N = sim)
    )
    lev <- append(lev, paste(type, "+", j, sep = ""))
    lev <- c(paste(type, "-", j, sep = ""), lev)
  }
  return(list(peak_temporal, lev))
}