R/funcs_set-get-scenario.R

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

#' Create element with curves selected to optimise over.
#'
#' This function takes a scenario object, selects the curves that will be used
#' in the optimisation and returns an updated scenario object with this
#' information.
#'
#' @param scenario A named list representing a scenario list-object.
#' @param subset_kpi_level1_id Expects an integer or integer vector.
#' @param subset_kpi_level2_id Expects an integer or integer vector.
#' @param subset_kpi_level3_id Expects an integer or integer vector.
#' @param subset_period_level1 Expects a string.
#'
#' @return An updated scenario list-object.
#'
#' @export
add_curves_filtered <- function(scenario,
                                subset_kpi_level1_id,
                                subset_kpi_level2_id,
                                subset_kpi_level3_id,
                                subset_period_level1) {
      # avoid notes when running devtools::check()
      kpi.level1_id <- NULL
      kpi.level2_id <- NULL
      kpi.level3_id <- NULL
      period_level1 <- NULL

      scenario$curves_filtered <- scenario$curves_full %>%
         dplyr::filter(
            kpi.level1_id  %in% subset_kpi_level1_id,
            kpi.level2_id  %in% subset_kpi_level2_id,
            kpi.level3_id  %in% subset_kpi_level3_id,
            period_level1  %in% subset_period_level1
         )

      return(scenario)
}

# Get scenario info ------------------------------------------------------------

#' Get key scenario information: period
#'
#' This function takes a scenario object, and returns either the period specified
#' in the scenario or a list containing all the possible periods
#'
#' @param scenario scenario list-object.
#' @param type string where \code{type = "all"} returns all possible options or
#' \code{type = "selected"} returns just the specified period
#'
#' @return character vector
#'
#' @export
get_scenario_period <- function(scenario,
                                type = "all"){

   # avoid notes when running devtools::check()
   period_level1 <- NULL

   check_for_curves_filtered <- scenario$curves_filtered %>% nrow()
   if(type == "selected" & check_for_curves_filtered == 0){

      period <- ""
      return(period)

   }

   if(type == "all"){ df <- scenario$curves_full }
   if(type == "selected"){ df <- scenario$curves_filtered }

   period <- df %>% dplyr::pull(period_level1) %>% unique()
   return(period)

}

#' Get key scenario information: kpi level1
#'
#' This function takes a scenario object, the required period, and returns all
#' the possible options for kpi level1 or the selected option
#'
#' @param scenario scenario list-object.
#' @param period string specifying the period required for the scenario
#' @param type string where \code{type = "all"} returns all possible options or
#' \code{type = "selected"} returns just the specified period
#'
#' @return character vector
#'
#' @export
get_scenario_kpi1 <- function(scenario,
                              period,
                              type = "all"){

   # avoid notes when running devtools::check()
   period_level1 <- NULL
   kpi.level1_name <- NULL
   kpi_unit <- NULL

   check_for_curves_filtered <- scenario$curves_filtered %>% nrow()
   if(type == "selected" & check_for_curves_filtered == 0){

      kpi1 <- ""
      return(kpi1)

   }

   if(type == "selected"){ df <- scenario$curves_filtered }
   if(type == "all"){

      df <- scenario$kpi_weights %>%
         dplyr::filter(period_level1 == period)
      }

   kpi1 <- df %>% dplyr::pull(kpi.level1_name) %>% unique()
   return(kpi1)

}

#' Get key scenario information: kpi level2
#'
#' This function takes a scenario object, the required period, the required kpi level1
#' and returns all the possible options for kpi level2 or the selected option
#'
#' @param scenario scenario list-object.
#' @param period string specifying the period required for the scenario
#' @param kpi1 string specifying the kpi1 name required for the scenario
#' @param type string where \code{type = "all"} returns all possible options or
#' \code{type = "selected"} returns just the specified period
#'
#' @return character vector
#'
#' @export
get_scenario_kpi2 <- function(scenario,
                              period,
                              kpi1,
                              type = "all"){

   # avoid notes when running devtools::check()
   period_level1 <- NULL
   kpi.level1_name <- NULL
   kpi.level2_name <- NULL
   kpi_unit <- NULL

   check_for_curves_filtered <- scenario$curves_filtered %>% nrow()
   if(type == "selected" & check_for_curves_filtered == 0){

      kpi2 <- ""
      return(kpi2)

   }

   if(type == "selected"){ df <- scenario$curves_filtered }
   if(type == "all"){

      df <- scenario$kpi_weights %>%
         dplyr::filter(period_level1 == period) %>%
         dplyr::filter(kpi.level1_name %in% kpi1)
      }

   kpi2 <- df %>% dplyr::pull(kpi.level2_name) %>% unique()
   return(kpi2)

}

#' Get key scenario information: kpi level3
#'
#' This function takes a scenario object, the required period, the required kpi
#' level1, kpi level2 and returns all the possible options for kpi level3 or the
#' selected option
#'
#' @param scenario scenario list-object.
#' @param period string specifying the period required for the scenario
#' @param kpi1 string specifying the kpi1 name required for the scenario
#' @param kpi2 string specifying the kpi2 name required for the scenario
#' @param type string where \code{type = "all"} returns all possible options or
#' \code{type = "selected"} returns just the specified period
#'
#' @return character vector
#'
#' @export
get_scenario_kpi3 <- function(scenario,
                              period,
                              kpi1,
                              kpi2,
                              type = "all"){

   # avoid notes when running devtools::check()
   period_level1 <- NULL
   kpi.level1_name <- NULL
   kpi.level2_name <- NULL
   kpi.level3_name <- NULL
   kpi_unit <- NULL

   check_for_curves_filtered <- scenario$curves_filtered %>% nrow()
   if(type == "selected" & check_for_curves_filtered == 0){

      kpi3 <- ""
      return(kpi3)

   }

   if(type == "selected"){ df <- scenario$curves_filtered }
   if(type == "all"){

      df <- scenario$kpi_weights %>%
         dplyr::filter(period_level1 == period) %>%
         dplyr::filter(kpi.level1_name %in% kpi1) %>%
         dplyr::filter(kpi.level2_name %in% kpi2)
   }

   kpi3 <- df %>% dplyr::pull(kpi.level3_name) %>% unique()
   return(kpi3)

}

#' Based off the selected period and kpis - is it possible to run a best case
#' scenario?
#'
#' This function returns \code{TRUE} if the selected scenario object, period and
#' kpis mean a best case scenario is possible
#'
#' @param scenario scenario list-object.
#' @param user_period string specifying the period required for the scenario
#' @param kpi1 string specifying kpi1 required for the scenario
#' @param kpi2 string specifying kpi2 required for the scenario
#' @param kpi3 string specifying kpi3 period required for the scenario
#' @return boolen where T means best case is possible
#' @export
is_bestcase_possible <- function(scenario,
                                 user_period,
                                 kpi1,
                                 kpi2 = NA,
                                 kpi3 = NA){

   # avoid notes when running devtools::check()
   period_level1 <- NULL
   kpi.level1_name <- NULL
   kpi.level2_name <- NULL
   kpi.level3_name <- NULL
   same_units <- NULL
   check <- NULL
   n <- NULL

   scenario$curves_full %>%
      dplyr::filter(period_level1 == user_period) %>%
      dplyr::filter(kpi.level1_name %in% kpi1) %>%
      dplyr::filter(kpi.level2_name %in% kpi2) %>%
      dplyr::filter(kpi.level3_name %in% kpi3) %>%
      dplyr::summarise(same_units = sum(same_units),
                       n = dplyr::n()) %>%
      dplyr::mutate(check = (same_units == n) & n > 0) %>%
      dplyr::pull(check)

}

#' Get key scenario information: budget
#'
#' This function takes a scenario object, and returns the budget selected
#'
#' @param scenario scenario list-object.
#' @return numeric vector of length 1
#'
#' @export
get_scenario_budget <- function(scenario){

   # avoid notes when running devtools::check()
   settings <- NULL
   value <- NULL

   scenario$settings %>%
      dplyr::filter(settings == "budget") %>%
      dplyr::pull(value)

}

#' Get key scenario information: period levels, channel levels and channel
#' level groupings
#'
#' This function takes a scenario object, and a period and returns a list
#' object, where each element of the list is a unique list of channel,
#' period, channel.group.level1, channel.group.level2, channel.group.level3. If a
#' scenario has already been set, then this is based off curves_filtered -
#' i.e. dependent on period and kpi, if not it's based off curves_full
#'
#' @param scenario scenario list-object.
#' @param user_period string specifying the period required for the scenario
#' @return named list-object where each element of the list is a unique set of values
#' @export
get_scenario_channels <- function(scenario, user_period){

   # avoid notes when running devtools::check()
   period_level1 <- NULL

   df <- scenario$curves_full %>%
      dplyr::filter(period_level1 == user_period)

   channel_name <- df %>% dplyr::pull(channel_name) %>% unique()
   period_level2.name <- df %>% dplyr::pull(period_level2.name) %>% unique()
   channel.group.level1_name <- df %>% dplyr::pull(channel.group.level1_name) %>% unique()
   channel.group.level2_name <- df %>% dplyr::pull(channel.group.level2_name) %>% unique()
   channel.group.level3_name <- df %>% dplyr::pull(channel.group.level3_name) %>% unique()

   list_channels <- list(channel = channel_name,
                         period_level2 = period_level2.name,
                         channel.group.level1 = channel.group.level1_name,
                         channel.group.level2 = channel.group.level2_name,
                         channel.group.level3 = channel.group.level3_name)

   return(list_channels)

}

#' Get key scenario information: constraints input tables
#'
#' This function takes a scenario object, and a period and returns a list
#' object, where each element of the list is constraints input table. The length
#' of the list will be equal to the number of constraints input tables specified
#' in the constraints settings table in the scenario object. By default,
#' most projects will have a table for channel, period, channel x period,
#' channel_level1, channel_level2, channel_level3. But other tables may be
#' specified
#'
#' @param scenario scenario list-object.
#' @param user_period string specifying the period required for the scenario
#' @return named list-object where each element of the list is a constraints
#' input table
#' @export
get_constraints_input_tables <- function(scenario, user_period){

   # avoid notes when running devtools::check()
   value <- NULL
   constraint.group_id <- NULL
   groups <- NULL
   constraint_min <- NULL
   constraint_max <- NULL

   # get a unique list of all channels and periods
   list_channels <- get_scenario_channels(scenario, user_period)
   df_constraints_existing <- get_constraints(scenario)

   # get the list of required constraints tables
   df <- scenario$constraints_settings

   # initialise an empty list
   list_input_tables <- list()

   # loop over each row of the table
   for (i in 1:nrow(df)){

      # store constraint.group_id
      constraint.group_id_i <- df %>%
         dplyr::slice(i) %>%
         dplyr::pull(constraint.group_id) %>%
         unique()

      # get a character vector specifying all the groups in the table
      df_temp <- df %>%
         dplyr::slice(i) %>%
         tidyr::pivot_longer(cols = -constraint.group_id,
                             names_to = "groups",
                             values_to = "value")

      groups_selected <- df_temp %>%
         dplyr::filter(value == 1) %>%
         dplyr::pull(groups)

      # store the other columns
      groups_other <- df_temp %>%
         dplyr::filter(is.na(value)) %>%
         dplyr::pull(groups)

      # subset total list by the groups required
      input_table <- list_channels[groups_selected] %>%
         expand.grid() %>%
         dplyr::as_tibble() %>%
         dplyr::mutate(min = NA,
                max = NA,
                constraint.group_id = constraint.group_id_i)

      # add the remaining empty columns
      groups_other_cols <- rep(NA, length(groups_other))
      names(groups_other_cols) <- groups_other

      # then join with existing constraints to get any pre loaded or saved values
      list_input_tables[[i]] <- input_table %>%
         dplyr::mutate(!!!groups_other_cols) %>%
         dplyr::left_join(df_constraints_existing, by = c("constraint.group_id",
                                     "channel" = "channel_name",
                                     "period_level2"="period_level2.name",
                                     "channel.group.level1"="channel.group.level1_name",
                                     "channel.group.level2"="channel.group.level2_name",
                                     "channel.group.level3"="channel.group.level3_name")) %>%
         dplyr::mutate(min = constraint_min,
                       max = constraint_max) %>%
         dplyr::select(-constraint_min,
                       -constraint_max)

      }

   return(list_input_tables)

}

#' Get key scenario information: constraints table
#'
#' This function takes a scenario object and returns the full combination of
#' constraints specified in the scenario as a tibble
#'
#' @param scenario scenario list-object.
#' @return tibble outlining all of the constraints in the table
#' @export
get_constraints <- function(scenario){

   # avoid notes when running devtools::check()
   constraint.group_id <- NULL
   constraint_id <- NULL
   channel_name <- NULL
   period_level2.name <- NULL
   channel.group.level1_id <- NULL
   channel.group.level1_name <- NULL
   channel.group.level2_id <- NULL
   channel.group.level2_name <- NULL
   channel.group.level3_id <- NULL
   channel.group.level3_name <- NULL
   constraint_min <- NULL
   constraint_max <- NULL

   scenario$constraints %>%
      dplyr::left_join(scenario$channel[c(1,2)], by = "channel_id") %>%
      dplyr::left_join(scenario$period[c(1,3)], by = "period_id") %>%
      dplyr::left_join(scenario$channel.group.level1, by = "channel.group.level1_id") %>%
      dplyr::left_join(scenario$channel.group.level2, by = "channel.group.level2_id") %>%
      dplyr::left_join(scenario$channel.group.level3, by = "channel.group.level3_id") %>%
      dplyr::select(constraint_id,
                    constraint.group_id,
                    channel_name,
                    period_level2.name = period_level2.name,
                    channel.group.level1_name,
                    channel.group.level2_name,
                    channel.group.level3_name,
                    constraint_min,
                    constraint_max) %>%
      dplyr::filter(!constraint_min == 0 | !is.na(constraint_max))

}

#' Convert constraints_table_by_name to constraints_table_by_id
#'
#' This function takes a constraints_table_by_name and returns constraints_table_by_id
#'
#' @param scenario scenario list-object.
#' @param constraints_table_by_name table of constraints by name
#' @return tibble of constraints_by_id ready to pass back to scenario
convert_constraints_table <- function(scenario,
                                      constraints_table_by_name){

   # avoid notes when running devtools::check()
   constraint_id <- NULL
   channel_id <- NULL
   period_id <- NULL
   constraint.group_id <- NULL
   channel.group.level1_id <- NULL
   channel.group.level2_id <- NULL
   channel.group.level3_id <- NULL
   constraint_min <- NULL
   constraint_max <- NULL

   constraints_table_by_name %>%
      dplyr::left_join(scenario$channel[c(1,2)], by = "channel_name") %>%
      dplyr::left_join(scenario$period[c(1,3)], by = "period_level2.name") %>%
      dplyr::left_join(scenario$channel.group.level1, by = "channel.group.level1_name") %>%
      dplyr::left_join(scenario$channel.group.level2, by = "channel.group.level2_name") %>%
      dplyr::left_join(scenario$channel.group.level3, by = "channel.group.level3_name") %>%
      dplyr::select(constraint_id,
                    constraint.group_id,
                    channel_id,
                    period_id,
                    channel.group.level1_id,
                    channel.group.level2_id,
                    channel.group.level3_id,
                    constraint_min,
                    constraint_max)

}



# Set scenario info ------------------------------------------------------------

#' Set key scenario information: period
#'
#' This function takes a scenario object, and updates the scenario to optimise
#' to the desired period
#'
#' @param scenario scenario list-object.
#' @param period the specified period as a string
#' @return updated scenario list-object
#' not exported as it is called by the set_scenario function
set_scenario_period <- function(scenario,
                                period = ""){

   # avoid notes when running devtools::check()
   period_level1 <- NULL

   scenario$curves_filtered <- scenario$curves_full %>%
      dplyr::filter(period_level1 == period)

   return(scenario)

}
# NOTE: this can be nested, as we use filter the kpi_weights table when the user
# is setting scenarios (to avoid inadvertently changing the curves_filtered) table
# until we have all of the information

#' Set key scenario information: kpi
#'
#' This function takes a scenario object, and updates the scenario to optimise
#' to the desired kpis, by updating or populating curves_filtered
#'
#' @param scenario scenario list-object.
#' @param kpi1 the specified kpilevel1 as a string
#' @param kpi2 the specified kpilevel2 as a string
#' @param kpi3 the specified kpilevel3 as a string
#' @return updated scenario list-object
#' not exported as it is called by the set_scenario function, AFTER set_scenario_period
#' - the order is important
set_scenario_kpi <- function(scenario,
                             kpi1,
                             kpi2 = NULL,
                             kpi3 = NULL){

   # avoid notes when running devtools::check()
   period_level1 <- NULL
   kpi.level1_name <- NULL
   kpi.level2_name <- NULL
   kpi.level3_name <- NULL

   df <- scenario$curves_filtered

   df <- df %>%
      dplyr::filter(apply_filter(kpi.level1_name, kpi1)) %>%
      dplyr::filter(apply_filter(kpi.level2_name, kpi2)) %>%
      dplyr::filter(apply_filter(kpi.level3_name, kpi3))

   # check df is populated before assigning to curves_filtered
   if(df %>% nrow() > 0){ scenario$curves_filtered <- df}

   return(scenario)

}

#' Set key scenario information: budget or target
#'
#' This function takes a scenario object, and updates the scenario to optimise
#' to the desired budget or target. If a base case scenario is required - budget
#' and target should be NA
#'
#' @param scenario scenario list-object.
#' @param user_budget the specified budget as a numeric (no units) or NA if best case
#' @param user_target the specified target as a numeric (no units) or NA if no target required
#' @return updated scenario list-object
#' not exported as it is called by the set_scenario function
#'
set_scenario_settings <- function(scenario,
                                  user_budget = NA,
                                  user_target = NA){

   # avoid notes when running devtools::check()
   settings <- NULL
   value <- NULL
   budget <- NULL
   target <- NULL
   everything <- NULL

   scenario$settings <- scenario$settings %>%
      tidyr::pivot_wider(names_from = settings,
                         values_from = value) %>%
      dplyr::mutate(budget = user_budget,
                    target = user_target) %>%
      tidyr::pivot_longer(cols = everything(),
                          names_to = "settings",
                          values_to = "value") %>%
      dplyr::mutate(value = as.numeric(value))

   return(scenario)

}

#' Set key scenario information: constraints
#'
#' This function takes a scenario object, and updates the scenario to optimise
#' to the desired budget or target. If a base case scenario is required - budget
#' and target should be NA
#'
#' @param scenario scenario list-object.
#' @param constraints_list list, where each element of the list is an updated
#' constraints table matching at least one of the constraints groupings set in
#' the scenario_settings table
#' @return updated scenario list-object
#' not exported as it is called by the set_scenario function
#'
set_scenario_constraints <- function(scenario,
                                  constraints_list){

   # avoid notes when running devtools::check()
   settings <- NULL
   value <- NULL

   # NOTE: add a check to ensure the table can be found in the constraints settings table

   constraints_existing <- get_constraints(scenario)
   df <- dplyr::bind_rows(constraints_list)

   # join to get the user values
   constraints_update <- constraints_existing %>%
      dplyr::left_join(df, by = c("constraint.group_id",
                              "channel_name" = "channel",
                              "period_level2.name"="period_level2",
                              "channel.group.level1_name"="channel.group.level1",
                              "channel.group.level2_name"="channel.group.level2",
                              "channel.group.level3_name"="channel.group.level3")) %>%
      dplyr::mutate(constraint_min = min,
                    constraint_max = max) %>%
      dplyr::select(-min, -max) %>%
      dplyr::mutate(constraint_id = seq(1, nrow(constraints_existing)))

   # format it back the same way
   scenario$constraints <- convert_constraints_table(scenario, constraints_update)

   return(scenario)

}

#' Set all scenario information
#'
#' This function takes a scenario object, plus the desired optimisation specification
#' parameters, and updates the scenario object by updating or populating curves_filtered
#'
#' @param scenario scenario list-object.
#' @param period the specified period as a string
#' @param budget the specifed budget as a numeric
#' @param kpi1 the specified kpilevel1 as a string
#' @param kpi2 the specified kpilevel2 as a string
#' @param kpi3 the specified kpilevel3 as a string
#' @param constraints_list list where each element is a tibble with required constraints
#' @return updated scenario list-object, with curves_filtered ready to pass to optimisation
#' @export
#'
set_scenario <- function(scenario,
                         period,
                         budget,
                         kpi1,
                         kpi2 = NULL,
                         kpi3 = NULL,
                         constraints_list = NULL){

   # avoid notes when running devtools::check()
   period_level1 <- NULL

   scenario_new <- scenario

   scenario_new <- set_scenario_period(scenario_new, period)
   scenario_new <- set_scenario_kpi(scenario_new, kpi1, kpi2, kpi3)
   scenario_new <- set_scenario_settings(scenario_new, budget)

   if(!is.null(constraints_list)) { scenario_new <- set_scenario_constraints(scenario_new, constraints_list)}



   scenario_new$name$description <- get_scenario_description(scenario_new,
                                                             period,
                                                             budget,
                                                             kpi1,
                                                             kpi2,
                                                             kpi3,
                                                             constraints_list)






   # check df is populated before returning back the scenario
   # NOTE: add more scenario checks here?
   if(scenario_new$curves_filtered %>% nrow() > 0){ scenario <- scenario_new }

   return(scenario)

}


#' Get scenario description
#'
#' @param scenario a scenario list-object
#' @param period the specified period as a string
#' @param budget the specifed budget as a numeric
#' @param kpi1 the specified kpilevel1 as a string
#' @param kpi2 the specified kpilevel2 as a string
#' @param kpi3 the specified kpilevel3 as a string
#' @param constraints_list list where each element is a tibble with required constraints
#'
#' @return a string describing the optimisation ran
#' @export
#'
get_scenario_description <- function(scenario,
                                     period,
                                     budget,
                                     kpi1,
                                     kpi2 = NULL,
                                     kpi3 = NULL,
                                     constraints_list = NULL){
      period_string <- stringr::str_to_title(period)
      kpi_string <- stringr::str_to_title(kpi1)
      currency_symbol <- get_currency_symbol(scenario)
      budget_string <- if (is.na(budget)) "Best Case" else scales::number(as.numeric(budget),
                                                                          scale = 1e-6,
                                                                          suffix = "M",
                                                                          prefix = currency_symbol)

      constraints_string <- if(!is.null(constraints_list)) " with constraints" else ""

      description_string <- paste0(period_string, ", ",
                                   kpi_string,    ", ",
                                   budget_string,
                                   constraints_string)
}

#' Get currency symbol
#'
#' You can find Unicode Character symbols here https://unicode-table.com/en/
#' @param scenario a scenario list-object
#'
#' @return a character currency symbol
#' @export
#'
get_currency_symbol <- function(scenario){
      currency_string <- scenario$curves_full$alloc.unit_currency %>%
            utils::head(1)

      currency_symbol <- currency_string_to_symbol(currency_string)

      return(currency_symbol)
}

currency_string_to_symbol <- function(string){
      currency_symbol <- switch(string,
             "pounds"  = "\u00A3",
             "dollars" = "\u0024"
      )

      if (is.null(currency_symbol)) currency_symbol = ""

      return(currency_symbol)
}