R/funcs_optim-utils.R

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

get_optim_opts <- function(scenario, optim_type) {
      if (optim_type == "net") {
            tol_constraints_eq <- NULL
      } else {
            tol_constraints_eq <- rep(0.4, scenario$constraints_strings$num_constraints_eq)
      }

      out <- list(
            "algorithm"   = "NLOPT_LD_SLSQP",
            "xtol_rel"    = 1e-5,
            "ftol_abs"    = 1e-4,
            "maxeval"     = 2000,
            "maxtime"     = 60,
            "tol_constraints_ineq" = rep(0.4, scenario$constraints_strings$num_constraints_ineq),
            "tol_constraints_eq" = tol_constraints_eq,
            "print_level" = 0, # stop nlopt from printing
            "randseed"    = 1
      )
}

get_eval_f <- function(optim_type){
      if (optim_type == "alloc")     return(optim_alloc)
      if (optim_type == "alloc_pct") return(optim_alloc_pct)
      if (optim_type == "net")       return(optim_alloc_net)
}

get_eval_const <- function(scenario, optim_type) {
      eval_g_ineq <- function(x, curve_equations, constant,
                              p1, p2, p3,
                              p4, p5, p6,
                              p7, p8, p9) {
            eval(parse(text = scenario$constraints_strings$constraint_function))
      }

      eval_jac_g_ineq <- function(x, curve_equations, constant,
                                  p1, p2, p3,
                                  p4, p5, p6,
                                  p7, p8, p9) {
            eval(parse(text = scenario$constraints_strings$constraint_jacobian))
      }

      if (optim_type == "net") {
            eval_g_eq     <- NULL
            eval_jac_g_eq <- NULL
      } else {
            eval_g_eq <- function(x, curve_equations, constant,
                                  p1, p2, p3,
                                  p4, p5, p6,
                                  p7, p8, p9) {
                  eval(parse(text = scenario$constraints_strings$budget_function))
            }
            eval_jac_g_eq <- function(x, curve_equations, constant,
                                      p1, p2, p3,
                                      p4, p5, p6,
                                      p7, p8, p9) {
                  eval(parse(text = scenario$constraints_strings$budget_jacobian))
            }
      }

      return(
            list(
                  .eval_g_ineq = eval_g_ineq,
                  .eval_jac_g_ineq = eval_jac_g_ineq,
                  .eval_g_eq = eval_g_eq,
                  .eval_jac_g_eq = eval_jac_g_eq
            )
      )
}

add_optim_results <- function(curves_full, optim_spend){
      # remove previous results
      curves_full$optim_spend           <- NULL
      curves_full$response_at_optim     <- NULL
      # curves_full$same_units            <- NULL
      curves_full$net_response_at_optim <- NULL

      curves_full %>%
            dplyr::left_join(optim_spend, by = "alloc.unit_id") %>%
            dplyr::mutate(
                  response_at_optim = dplyr::case_when(
                        equation == "dim_rets" ~ dimrets_function(optim_spend, param1, param2),
                        equation == "s_curve"  ~ s_curve_function(optim_spend, param1, param2, param3, param4),
                        equation == "linear" ~ linear_function(optim_spend, param1)
                  ), # remove as now in funcs_scen
                  # same_units = dplyr::case_when(
                  #       kpi_unit == alloc.unit_currency ~ 1,
                  #       TRUE ~ 0
                  # ),
                  net_response_at_optim = dplyr::case_when(
                        same_units == 1 & equation == "dim_rets" ~
                              net_dimrets_function(optim_spend, param1, param2),
                        same_units == 1 & equation == "s_curve"  ~
                              net_s_curve_function(optim_spend, param1, param2, param3, param4),
                        same_units == 1 & equation == "linear"  ~
                              net_linear_function(optim_spend, param1),
                        TRUE ~ NA_real_
                  )
            )
}

get_data_optim <- function(scenario){

      equation <- NULL
      param1 <- NULL
      param2 <- NULL
      param3 <- NULL
      param4 <- NULL
      param5 <- NULL
      param6 <- NULL
      param7 <- NULL
      param8 <- NULL
      param9 <- NULL
      alloc.unit_id <- NULL
      channel_id <- NULL
      channel.group.level1_id <- NULL
      channel.group.level2_id <- NULL
      channel.group.level3_id <- NULL
      period_id <- NULL

      scenario$curves_filtered %>%
            dplyr::select(
                  alloc.unit_id,
                  channel_id,
                  channel.group.level1_id,
                  channel.group.level2_id,
                  channel.group.level3_id,
                  period_id,
                  equation,
                  param1,param2,param3,
                  param4,param5,param6,
                  param7,param8,param9
            ) %>%
            tidyr::nest(
                  equation = equation,
                  param1 = param1,param2 = param2,param3 = param3,
                  param4 = param4,param5 = param5,param6 = param6,
                  param7 = param7,param8 = param8,param9 = param9
            )
}