R/read_scenarios.R

In Matherion/mdmcda: Multi Decision Multi Criteria Decision Analysis

#' @export
read_scenarios <- function(input,
                           extension = "jmd",
                           regex = NULL,
                           recursive = TRUE,
                           encoding = "UTF-8",
                           decisions_and_alternatives) {

  criterionId_col <- mdmcda::opts$get("criterionId_col");
  decisionId_col <- mdmcda::opts$get("decisionId_col");
  decisionLabel_col <- mdmcda::opts$get("decisionLabel_col");
  alternativeValue_col <- mdmcda::opts$get("alternativeValue_col");
  alternativeLabel_col <- mdmcda::opts$get("alternativeLabel_col");

  if (!(all(c("mdmcda", "decisions_and_alternatives") %in%
            class(decisions_and_alternatives)))) {
    stop("What you pass as 'decisions_and_alternatives' needs to be an object as ",
         "generated by a call to the `read_decisions` function (which has ",
         "classes 'dmcda' and 'decisions_and_alternatives', but you ",
         "passed an object of class ",
         vecTxtQ(class(decisions_and_alternatives)), ".");
  }

  decisionsDf <-
    decisions_and_alternatives$decisionsDf;
  alternativesDf <-
    decisions_and_alternatives$alternativesDf;

  ### Set regex is only extension was provided
  if (is.null(regex)) {
    regex <- paste0("^(.*)\\.", extension, "$");
  }

  ### Use suppressWarnings because we do not need identifiers
  suppressWarnings(
    scenarios_raw <-
      justifier::read_justifications_dir(input,
                                         regex = regex,
                                         recursive = recursive,
                                         encoding=encoding)
  );

  ### Get all policy scenario metadata and choices
  scenariosMetadata <-
    lapply(scenarios_raw$supplemented$justifications,
           function(x) {
             if (x$type == "scenario_metadata") {
               return(x);
             } else {
               return(NULL);
             }
           });

  scenariosMetadata <-
    scenariosMetadata[!unlist(lapply(scenariosMetadata,
                                     is.null))];

  scenarioAlternatives <-
    lapply(scenarios_raw$supplemented$justifications,
           function(x) {
             if (x$type == "scenario_alternative_specification") {
               return(x);
             } else {
               return(NULL);
             }
           });

  ### Remove NULL elements
  scenarioAlternatives <-
    scenarioAlternatives[!unlist(lapply(scenarioAlternatives, is.null))];

  ### Convert to dataframes
  scenariosMetadataDf <-
    do.call(rbind,
            lapply(scenariosMetadata,
                   function(x) {
                     return(data.frame(scenario_id = x$scenario_id,
                                       label = x$label,
                                       description = x$description,
                                       stringsAsFactors = FALSE));
                   }));

  row.names(scenariosMetadataDf) <-
    NULL;

  scenarioAlternativesDf <-
    do.call(rbind,
            lapply(scenarioAlternatives,
                   function(x) {
                     res <-
                       data.frame(scenario_id = scenariosMetadataDf[scenariosMetadataDf$scenario_id==x$scenario_id, 'label'],
                                  decision_label = decisionsDf[decisionsDf$id==x$decision_id, 'label'],
                                  alternative_label = alternativesDf[alternativesDf$decision_id==x$decision_id &
                                                       alternativesDf$value==x$value, 'label'],
                                  scenario_id = x$scenario_id,
                                  decision_id = x$decision_id,
                                  alternative_value = x$value,
                                  stringsAsFactors = FALSE);
                     names(res) <-
                       c('scenario_id',
                         'decision_label',
                         'alternative_label',
                         'scenario_id',
                         'decision_id',
                         alternativeValue_col);
                     return(res);
                   }));

  row.names(scenarioAlternativesDf) <-
    NULL;

  res <- list(scenarios_raw = scenarios_raw,
              scenariosMetadata = scenariosMetadata,
              scenariosMetadataDf = scenariosMetadataDf,
              scenarioAlternatives = scenarioAlternatives,
              scenarioAlternativesDf = scenarioAlternativesDf);

  class(res) <-
    c("mdmcda", "scenarios");

  return(res);

}