R/funcs_constraints.R

In cath-parkinson/mm.reoptimise: Run and Compare Budget Optimisation in Different Scenarios

#' Get constraints strings to be used in the optimisation.
#'
#' The function was written in order to return objects that will be used by
#' the `nloptr` package.
#' @param scenario A named list representing a scenario list-object.
#' @param optim_type A string specifying the type of optimisation to be ran
#' @param constant Numeric.
#'
#' @return A list with 4 elements:
#'
#' `num_constraints_eq` Numeric. Number of equality constraints.
#'
#' `budget_function` Character string. Used to set equality constraint.
#'
#' `budget_jacobian` Character string. Used to set equality constraint.
#'
#' `num_constraints_ineq` Numeric. Number of inequality constraints.
#'
#' `constraint_function` Character string. Used to set inequality constraints.
#'
#' `constraint_jacobian` Character string. Used to set inequality constraints.
#'
#' @export
#'
#' @examples
#' \dontrun{
#' scenario <- create_scenario("data/scenario_0")
#' const_strings <- get_constraints_strings(scenario, 1e-6)
#' }
get_constraints_strings <- function(scenario, optim_type, constant) {
      # avoid notes when running devtools::check()
      channel.group.level1_id <- NULL
      channel.group.level2_id <- NULL
      channel.group.level3_id <- NULL
      channel_id              <- NULL
      constraint_id           <- NULL
      constraint_max          <- NULL
      constraint_min          <- NULL
      constraint_value        <- NULL
      constraint_var          <- NULL
      constraint_var_level    <- NULL
      period_id               <- NULL
      string_function         <- NULL
      string_jacobian         <- NULL
      subset_string           <- NULL
      settings           <- NULL
      value           <- NULL
      period_level1 <- NULL

      subset_period_level1 <- scenario$curves_filtered %>%
            dplyr::pull(period_level1) %>%
            unique()

      subset_period <- scenario$period %>%
            dplyr::filter(period_level1 == subset_period_level1)

      if(optim_type == "alloc_pct") constant = 1

      budget <- scenario$settings %>%
         dplyr::filter(settings == "budget") %>%
         dplyr::pull(value) %>%
         `*`(constant) %>%
         format(scientific = FALSE)

      if (identical(budget, character(0))){
            n_const_eq <- 0
            budget_string_fun <- "NULL"
            budget_string_jac <- "NULL"
      } else {
            n_const_eq <- 1
            budget_string_fun <- paste0("sum(x) - ", budget)
            budget_string_jac <- "rep(1, nrow(scenario$data_optim))"
      }

      constraints_strings <- scenario$constraints %>%
            dplyr::filter(period_id %in% c(subset_period$period_id, NA)) %>%
            tidyr::pivot_longer(
                  cols = c(
                        channel_id,
                        period_id,
                        channel.group.level1_id,
                        channel.group.level2_id,
                        channel.group.level3_id

                  ),
                  names_to = "constraint_var",
                  values_to = "constraint_var_level"
            ) %>%
            dplyr::filter(!is.na(constraint_var_level)) %>%
            dplyr::mutate(subset_string =
                                paste0(
                                      "scenario$data_optim$",
                                      constraint_var,
                                      " == ",
                                      constraint_var_level
                                )) %>%
            dplyr::group_by(constraint_id, constraint_min, constraint_max) %>%
            dplyr::summarise(subset_string =
                                   stringr::str_c(subset_string, collapse = " & ")) %>%
            dplyr::ungroup() %>%
            tidyr::pivot_longer(
                  cols = c(constraint_min, constraint_max),
                  names_to = "constraint_type",
                  values_to = "constraint_value"
            ) %>%
            dplyr::filter(!is.na(constraint_value)) %>%
            dplyr::mutate(
                  constraint_value = constraint_value * constant,
                  string_function = dplyr::case_when(
                        constraint_type == "constraint_min" ~
                              stringr::str_c("-sum(x[", subset_string, "]) + ", constraint_value, ","),

                        constraint_type == "constraint_max" ~
                              stringr::str_c("sum(x[", subset_string, "]) - ", constraint_value, ",")
                  ),
                  string_jacobian = dplyr::case_when(
                        constraint_type == "constraint_min" ~
                              stringr::str_c("-as.numeric(", subset_string, "),"),

                        constraint_type == "constraint_max" ~
                              stringr::str_c("as.numeric(", subset_string, "),")
                  )
            ) %>%
            dplyr::select(string_function, string_jacobian) %>%
            dplyr::summarise(
                  n_const_ineq = dplyr::n(),
                  string_function = stringr::str_c(string_function, collapse = " "),
                  string_jacobian = stringr::str_c(string_jacobian, collapse = " ")
            )

      n_const_ineq <- constraints_strings$n_const_ineq

      const_function <- paste0("rbind(",
                               constraints_strings$string_function,
                               " NULL)")

      jacob_fun = paste0("rbind(",
                         constraints_strings$string_jacobian,
                         " NULL)")

      return(
            list(
                  num_constraints_eq = n_const_eq,
                  budget_function    = budget_string_fun,
                  budget_jacobian    = budget_string_jac,
                  num_constraints_ineq = n_const_ineq,
                  constraint_function  = const_function,
                  constraint_jacobian  = jacob_fun
            )
      )
}