R/read_estimates_from_yml.R

In Matherion/mdmcda: Multi Decision Multi Criteria Decision Analysis

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

  criterionId_col <- mdmcda::opts$get("criterionId_col");
  criterionLabel_col <- mdmcda::opts$get("criterionLabel_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 'instruments_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)), ".");
  }
  if (!(all(c("mdmcda", "criteria") %in%
            class(criteria)))) {
    stop("What you pass as 'instruments_and_alternatives' needs to be an object as ",
         "generated by a call to the `read_outcomes` function (which has ",
         "classes 'dmcda' and 'criteria', but you ",
         "passed an object of class ",
         vecTxtQ(class(criteria)), ".");
  }

  decisionsDf <-
    decisions_and_alternatives$decisionsDf;
  alternativesDf <-
    decisions_and_alternatives$alternativesDf;
  criteriaDf <-
    criteria$criteriaDf;

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

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

  ### Get all estimates
  estimates <-
    lapply(estimates_raw$supplemented$justifications,
           function(x) {
             if (!is.null(x$type) && x$type == "estimate") {
               return(x);
             } else {
               return(NULL);
             }
           });

  ### Get all assertions and sources
  assertions <-
    estimates_raw$supplemented$assertions;
  sources <-
    estimates_raw$supplemented$sources;

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

  estimatesDf <-
    do.call(rbind,
            lapply(estimates,
                   function(x) {
                     decision <- x$decision;
                     res <-
                       data.frame(decision_id = x$decision_id,
                                  decision_label = decisionsDf[decisionsDf$id==x$decision_id, 'label'],
                                  alternative_value = x[, alternativeValue_col],
                                  alternative_label = alternativesDf[alternativesDf$decision_id==x$decision_id &
                                                             alternativesDf$value==x[, alternativeValue_col], 'label'],
                                  criterion_id = x$criterion_id,
                                  criterion_label = criteriaDf[criteriaDf$id==x$criterion_id, 'label'],
                                  value = x$value,
                                  label = x$label,
                                  description = x$description,
                                  id = x$id,
                                  stringsAsFactors = FALSE);
                     return(res);
                   }));

  row.names(estimatesDf) <-
    NULL;

  res <- list(estimates_raw = estimates_raw,
              estimates = estimates,
              assertions = assertions,
              sources = sources,
              estimatesDf = estimatesDf);

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

  return(res);

}