R/read_weights.R

In Matherion/mdmcda: Multi Decision Multi Criteria Decision Analysis

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

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

  criteriaTree <- criteria$criteriaTree;
  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(
    weights_raw <-
      justifier::read_justifications_dir(input,
                                         regex = regex,
                                         recursive = recursive,
                                         encoding=encoding)
  );

  ### Get all policy instrument weights
  weights <-
    lapply(weights_raw$supplemented$justifications,
           function(x) {
             if (x$type == "criterion_weight") {
               return(x);
             } else {
               return(NULL);
             }
           });

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

  ### Create
  weightDf <-
    do.call(rbind,
            lapply(weights,
                   function(x) {
                     if (is.null(x$criterion_id)) {
                       cat("For one of the weights, the criterion id is not set; ignoring it.\n");
                       return(NULL);
                     }
                     if (is.null(x$weight)) {
                       cat("For one of the weights, the weight is not set; ignoring it.\n");
                       return(NULL);
                     }
                     if (is.null(x$weight_profile_id)) {
                       cat("For one of the weights, the weight profile id is not set; ignoring it.\n");
                       return(NULL);
                     }
                     return(do.call(data.frame, x));
                   }));

  ###---------------------------------------------------------------------------
  ### Set default weights for unspecified criteria
  ###---------------------------------------------------------------------------

  weightProfiles <-
    unique(weightDf$weight_profile_id);

  idCounter <- 1;

  for (currentProfile in weightProfiles) {

    criteria_with_weights <-
      weightDf[weightDf$weight_profile_id == currentProfile,
               'criterion_id'];

    criteriaWithoutWeights <-
      criteriaDf$id[!(criteriaDf$id %in% criteria_with_weights)];

    for (i in criteriaWithoutWeights) {
      weights <-
        c(weights,
          list(structure(list(criterion_id = i,
                              weight = defaultWeight,
                              weight_profile_id = currentProfile,
                              type = "criterion_weight",
                              id = paste0("id_autoGenerated_", idCounter)),
                         class = c("justifierSpec", "justification"))));
    }

    idCounter <- idCounter + 1;
  }

  weightsDf <-
    do.call(rbind,
            lapply(weights,
                   function(x) {
                     if (x$criterion_id %in% criteriaDf$id) {
                       criterionLabel <-
                         unname(criteriaDf[criteriaDf$id==x$criterion_id, 'label']);
                     } else {
                       criterionLabel <-
                         "Criterion not specified";
                     }
                     res <-
                       data.frame(x$weight_profile_id,
                                  x$criterion_id,
                                  criterionLabel,
                                  x$weight,
                                  stringsAsFactors = FALSE);
                     names(res) <-
                       c('weight_profile_id',
                         'criterion_id',
                         'criterion_label',
                         'weight');
                     return(res);
                   }));

  row.names(weightsDf) <-
    NULL;

  ### Get logical vector specifying which weights have been specified
  ### for criteria that have also been specified
  validWeights <-
    weightsDf$criterion_id %in% criteriaDf$id;

  validWeightsDf <-
    weightsDf[validWeights, ];

  ### Multiply the weights
  multipliedWeights <-
    lapply(unique(validWeightsDf$weight_profile_id),
           function(profile) {
             res <-
               data.frame(criterion_id = validWeightsDf[validWeightsDf$weight_profile_id==profile, 'criterion_id'],
                          multipliedWeight =
                            unlist(lapply(validWeightsDf[validWeightsDf$weight_profile_id==profile,
                                                         'criterion_id'],
                                          function(id) {
                                            idList <-
                                              data.tree::FindNode(criteriaTree,
                                                                  id)$Get("id",
                                                                          traversal="ancestor");
                                            return(prod(validWeightsDf[validWeightsDf$weight_profile_id==profile &
                                                                         validWeightsDf$outcome_id %in% idList, 'weight']));
                                          })));
             res$profile_id <-
               rep(profile,
                   nrow(res));
             return(res);
           });

  multipliedWeights <-
    do.call(rbind,
            multipliedWeights);

  res <- list(weights_raw = weights_raw,
              weights = weights,
              weightsDf = validWeightsDf,
              fullWeightsDf = weightsDf,
              multipliedWeights = multipliedWeights);

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

  return(res);

}