R/funcs_scenarios.R

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

#' Create a scenario list-object.
#'
#' @param path Character string indicating the file path to the folder where
#' input_data.xlsx is located. If a Windows file path is supplied, remember
#' to replace the backslash (\) with either \\\\ or /.
#'
#' @return A named list representing a scenario list-object.
#' @export
#'
#' @examples
#' \dontrun{
#' create_scenario("data/scenario_0")
#' }
create_scenario <- function(path) {
      # avoid notes when running devtools::check()
      channel.group.level1_name <- NULL
      channel.group.level2_name <- NULL
      channel.group.level3_name <- NULL
      channel_name              <- NULL
      period_level2.name        <- NULL
      period_level2.order       <- NULL
      scenario_name             <- NULL
      date_ran                  <- NULL
      kpi.level1_name           <- NULL
      kpi.level2_name           <- NULL
      kpi.level3_name           <- NULL
      kpi.level1_weight           <- NULL
      kpi.level2_weight           <- NULL
      kpi.level3_weight           <- NULL
      . <- NULL
      kpi_unit <- NULL
      period_level1 <- NULL

      # assumes input file is called input_data.xlsx
      path_input_data <- file.path(path, "input_data.xlsx")

      # each sheet is read as a tibble
      sheets <- readxl::excel_sheets(path_input_data)
      scenario <- purrr::map(sheets, function(x) {
            readxl::read_excel(path_input_data, sheet = x)
      })
      names(scenario) <- sheets

      # format name table
      scenario$name <- scenario$name %>%
         dplyr::mutate(date_ran = as.Date(date_ran))

      # create joined tibble - if it isn't already there
      if(scenario$curves_full %>% nrow == 0) {

      scenario$curves_full <- scenario$curves %>%
         dplyr::left_join(scenario$kpi, by = "kpi_id") %>%
         dplyr::left_join(scenario$kpi.level1, by = "kpi.level1_id") %>%
         dplyr::left_join(scenario$kpi.level2, by = "kpi.level2_id") %>%
         dplyr::left_join(scenario$kpi.level3, by = "kpi.level3_id") %>%
         dplyr::left_join(scenario$channel, by = "channel_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::left_join(scenario$period, by = "period_id") %>%
         dplyr::left_join(scenario$alloc.unit, by = "alloc.unit_id") %>%
         dplyr::mutate(period_level2.name = as.character(period_level2.name)) %>%
         dplyr::mutate(
            scenario_name = scenario$name$name,
            period_level2.name = forcats::fct_reorder(period_level2.name,
                                                      period_level2.order),
            alloc.unit_name.without.period = paste(
               channel.group.level1_name,
               channel.group.level2_name,
               channel.group.level3_name,
               channel_name,
               sep = "_"
            )
         ) %>% # populate same_units here, so that we can use
         dplyr::mutate(same_units = dplyr::case_when(
            kpi_unit == alloc.unit_currency ~ 1,
            TRUE ~ 0)) %>%
         dplyr::select(scenario_name, dplyr::everything())

      }

      if(scenario$curves_filtered %>% nrow() > 0){

         scenario$curves_filtered <- scenario$curves_filtered %>%
            dplyr::mutate(period_level2.name = as.character(period_level2.name)) %>%
            dplyr::mutate(period_level2.name = forcats::fct_reorder(period_level2.name,
                                                                    period_level2.order))

      }

      # Add a summary KPI table to make it easy to view weights and get levels
      scenario$kpi_weights <- scenario$curves_full %>%
         dplyr::select(period_level1,
                       kpi.level1_name,
                       kpi.level2_name,
                       kpi.level3_name,
                       kpi_unit,
                       kpi.level1_weight,
                       kpi.level2_weight,
                       kpi.level3_weight) %>%
         dplyr::distinct() %>%
         dplyr::mutate(master_weight = rowMeans(dplyr::select(., dplyr::contains("weight")),
                                                na.rm =T))

      return(scenario)
}

#' Create a list of scenario list-objects.
#'
#' @param path Character string indicating the file path to the folder where the
#' scenario folders that contain the input_files are located.
#'
#' It is assumed that the folders that contain the input_files are named
#' scenario_N (N: 0, 1, 2, ...)
#'
#' If a Windows file path is supplied, remember to replace the backslash (\)
#' with either \\\\ or /.
#'
#' @return A list where each element is a scenario list-object.
#' @export
#'
#' @examples
#' \dontrun{
#' create_scenario_list("data")
#' }
create_scenario_list <- function(path) {
      list_scenario_folders <- dir(path)[grepl("scenario_", dir(path))]
      scenario_list <- vector("list", length(list_scenario_folders))

      for (i in seq_along(scenario_list)) {
            scenario_folder <- file.path(path, list_scenario_folders[[i]])
            scenario_list[[i]] <- create_scenario(scenario_folder)
      }
      return(scenario_list)
}

#' Produce a summary of all the scenarios in the scenario list.
#'
#' @param scenario_list List where each element is a scenario list-object.
#' @return A tibble with information about the scenarios.
#' @export
#' @examples
#' \dontrun{
#' summarise_scenarios(scenario_list)
#' }
summarise_scenarios <- function(scenario_list) {
      summary_list <- lapply(scenario_list, function(x) {
            x$name
      })
      summary_table <- dplyr::bind_rows(summary_list)
      return(summary_table)
}

#' Produce a list of all the scenarios in the scenario list by name
#'
#' @param scenario_list List where each element is a scenario list-object.
#' @return A list with scenario names.
#' @examples
#' \dontrun{
#' list_out_scenarios(scenario_list)
#' }
list_out_scenarios <- function(scenario_list) {
      my_list <- sapply(scenario_list, function(x) {
            x$name$name
      })
      return(my_list)
}

#' Select a scenario from the scenario list by name
#'
#' @param scenario_list List where each element is a scenario list-object.
#' @param name Character string with the name of the scenario to be selected.
#' @return If `name` is valid, a single scenario list-object.
#' If not, a character string equal to "error: no matching scenario".
#' @examples
#' \dontrun{
#' select_scenario(scenario_list, name = "zero")
#' }
#' @export
select_scenario <- function(scenario_list, name) {
      names <- purrr::map_chr(scenario_list, function(x)
            x$name$name) #The name of a scenario is found in the file input_name
      selected_index <- which(names == as.character(name))

      selected_scenario <- tryCatch(
            scenario_list[[selected_index]],
            error = function(e)
                  "error: no matching scenario"
      )
}

#' Add a scenario or update a scenario in the scenario list by name
#'
#' @param scenario_list List where each element is a scenario list-object.
#' @param scenario A scenario list-object.
#' @param user_name Character string with the name of the scenario to be added or updated.
#' @return If the `scenario` is valid, an updated scenario list
#' If not, a character string equal to "error: your scenario is not complete, please review".
#' @examples
#' \dontrun{
#' add_scenario(scenario_list, scenario, user_name = "my new scenario")
#' }
#' @export
add_scenario <- function(scenario_list, scenario, user_name = NULL) {

   # Stop messages when checking package
   name <- NULL

   # if scenario invalid then stop function and return error message
   if(check_scenario(scenario) != T){

      return(check_scenario)

         } else if(user_name %in% list_out_scenarios(scenario_list)){

            # if scenario name is already found in list
            # then reassign scenario with new scenario passed
            index <- which(list_out_scenarios(scenario_list) %in% user_name)
            scenario_list[index] <- list(scenario)
            return(scenario_list)

   } else {

      # if pass

      # create new id
      create_unique_id <- paste0(2,sample(1:99999, 1)) %>% as.numeric()

      # assign information to new scenario
      # if user_name is not provided, leave name as "new"
      scenario$name <- scenario$name %>%
         dplyr::mutate(name = dplyr::if_else(is.null(user_name), name, user_name)) %>%
         dplyr::mutate(unique_id = create_unique_id) %>%
         dplyr::mutate(date_ran = Sys.Date())

      # assign new name to the curves_full table and the curves_filtered table (if present)
      scenario$curves_full <- scenario$curves_full %>% dplyr::mutate(scenario_name = user_name)

      check_for_curves_filtered <- scenario$curves_filtered %>% nrow()
      if(check_for_curves_filtered > 0){  scenario$curves_filtered <- scenario$curves_filtered %>% dplyr::mutate(scenario_name = user_name) }

      # add new user scenario to the list
      scenario <- list(scenario)
      scenario_list <- c(scenario_list, scenario)
      return(scenario_list)
   }

}
#' Check scenario is valid, and ready to run optimistion on it
#'
#' @param scenario A scenario list-object.
#' @return If the `scenario` is valid,  boolean `T`
#' If not, a character string equal to "error: your scenario is not complete, please review".
#' @examples
#' \dontrun{
#' check_scenario(scenario)
#' }
check_scenario <- function(scenario) {

   # this needs to be populated with checks
   # returns scenario if pass checks
   # returns error message using tryCatch if it fails

   return(T)
}

#' Remove a scenario from the scenario list by name or unique_id
#'
#' @param scenario_list List where each element is a scenario list-object.
#' @param user_name Character string with the name of the scenario to be removed.
#' @param user_unique_id Numeric vector of length 1 with the unique ID of the scenario to be removed.
#' @return An updated scenario list
#' @examples
#' \dontrun{
#' remove_scenario(scenario_list, user_name = NULL, user_unique_id = NULL)
#' }
#' @export
remove_scenario <- function(scenario_list, user_name = NULL, user_unique_id = NULL) {

   name <- NULL

   # find scenario to be removed
   if(is.null(user_name) & is.null(user_unique_id)){

      return("error: please enter a valid scenario name or unique_id")


   } else if(!is.null(user_unique_id)){

         unique_id <- tryCatch(

            as.numeric(user_unique_id),
            error = function(e)
               "error: no matching unique_id"
         )

         all_unique_id <- summarise_scenarios(scenario_list) %>%
            dplyr::pull(unique_id)

         selected_index <- which(user_unique_id == all_unique_id)

   } else {

      all_names <- summarise_scenarios(scenario_list) %>%
         dplyr::pull(name)

      selected_index <- which(user_name == all_names)

   }

   scenario_list <- tryCatch(

      scenario_list[c(-selected_index)],
      error = function(e)
         "error: no matching scenario")

}

#' Which scenarios in list have an optimisation result
#'
#' @param scenario_list A list of scenario list-objects.
#' @return A booleon vector of length scenario_list, where `T` indicates an optimisation result is present
#' @examples
#' \dontrun{
#' check_scenario_result_present(scenario_list)
#' }
#' @export
check_scenario_result_present <- function(scenario_list) {

   # stop notes when checking package
   optim_spend <- NULL

   check <- c()
   for (i in 1:length(scenario_list)){

   scenario <- scenario_list[[i]]

   # if optim_spend column is NA then check should return FALSE
   check[i] <- scenario$curves_full %>% dplyr::pull(optim_spend) %>% is.na() %>% all()
   check[i] <- !check[i]

      }

   return(check)
}





#' Create table that combines the optimisation results of all the scenarios
#' where the optimisation was run.
#'
#' @param scenario_list List where each element is a scenario list-object.
#'
#' @return A table where each row corresponds to a curve with the optimisation
#' results
#' @export
#'
create_all_scenarios_table <- function(scenario_list) {
      # avoid notes when running devtools::check()
      optim_spend <- NULL

      keep_curves_full <- purrr::map(scenario_list, function(x){
            x$curves_full
      })

      all_curves_full <- purrr::reduce(keep_curves_full, function(x, y){
            dplyr::bind_rows(x, y)
      }) %>%
            # ignore scenarios where optim was not run
            dplyr::filter(!is.na(optim_spend))

      return(all_curves_full)
}



#' Write scenario to excel file
#'
#' @param scenario_list List where each element is a scenario list-object.
#' @param scenario_name Name of the scenario you want to write
#' @param path file path to specify where file is to be written
#'
#' @export
#'
write_scenario <- function(scenario_list, scenario_name, path) {

   # Pull the desired scenario
   scenario <- mm.reoptimise::select_scenario(scenario_list, scenario_name)

   # Write the desired scenario to excel - matching the input file
   writexl::write_xlsx(list(name = scenario$name,
                            curves = scenario$curves,
                            kpi = scenario$kpi,
                            kpi.level1 = scenario$kpi.level1,
                            kpi.level2 = scenario$kpi.level2,
                            kpi.level3 = scenario$kpi.level3,
                            channel = scenario$channel,
                            channel.group.level1 = scenario$channel.group.level1,
                            channel.group.level2 = scenario$channel.group.level2,
                            channel.group.level3 = scenario$channel.group.level3,
                            period = scenario$period,
                            alloc.unit = scenario$alloc.unit,
                            settings = scenario$settings,
                            constraints_settings = scenario$constraints_settings,
                            constraints = scenario$constraints,
                            weights = scenario$weights,
                            curves_filtered = scenario$curves_filtered,
                            curves_full = scenario$curves_full,
                            kpi_weights = scenario$kpi_weights
                            ),
                       paste0(path, "/input_data.xlsx"))

   print(paste("Scenario", scenario_name, "written to file"))



}