public code v1

2026-05-23 00:32:57 +02:00
commit 759a8968a2
4357 changed files with 163763 additions and 0 deletions
@@ -0,0 +1,7 @@
+assert <- function(expression, message)
+{
+  if(!all(expression))
+  {
+    stop(if(is.null(message)) "Error" else message)
+  }
+}
@@ -0,0 +1,181 @@
+validateData <- function(bestToOthers, othersToWorst, criteriaNames){
+  assert(length(bestToOthers) > 1, "Length of the best-to-others or others-to-worst vector should have at least 2 elements.")
+  assert(length(bestToOthers) == length(othersToWorst), "Lengths of best-to-others and others-to-worst vectors must be the same.")
+  assert(length(bestToOthers) == length(criteriaNames), "Lengths of best-to-others and criteriaNames must be the same.")
+  assert(1 %in% bestToOthers, "best-to-others vector should contain number 1.")
+  assert(1 %in% othersToWorst, "others-to-worst vector should contain number 1.")
+  assert(all(bestToOthers >= 1) && all(bestToOthers <= 9), "Numbers in best-to-others vector should be in range <1, 9>.")
+  assert(all(othersToWorst >= 1) && all(othersToWorst <= 9), "Numbers in others-to-worst vector should be in range <1, 9>.")
+  bestToOthersOneIndex <- match(1, bestToOthers)
+  othersToWorstOneIndex <- match(1, othersToWorst)
+  assert(!is.na(bestToOthersOneIndex) && !is.na(othersToWorstOneIndex), "best-to-others and others-to-worst vectors must contain number `1`.")
+  list(bestToOthers = bestToOthers, othersToWorst = othersToWorst, criteriaNames = criteriaNames)
+}
+
+isConsistent <- function(model){
+  worstCriterionIndex <- match(1, model$othersToWorst)
+  bestOverWorstPreferenceValue <- model$bestToOthers[worstCriterionIndex]
+
+  # a_bj x a_jw = a_bw for all j
+  list(isConsistent = all(model$bestToOthers*model$othersToWorst == bestOverWorstPreferenceValue), a_bw = bestOverWorstPreferenceValue)
+}
+# tries to combine constraint, if constraint already belongs to the constraints set then
+# it resturns constraints and a flag that indicates that constraints' state hasn't been changed
+combineConstraints <- function(constraints, constraint){
+  assert(!is.null(constraint$lhs), "Constraint should contain lhs vector")
+  assert(!is.null(constraint$rhs), "Constraint should contain rhs vector")
+  assert(!is.null(constraint$dir), "Constraint should contain direction sign")
+  assert(constraint$dir %in% c("<=", "==", ">="), "Constraint should be one of the following `<=, ==, >=`")
+  index <- length(constraints)+1
+  #return when such constraint is already in constraints list
+  for(x in constraints){
+    if( length(setdiff(x, constraint)) == 0 ){
+      return(list(constraints = constraints, added = FALSE))
+    }
+  }
+
+  constraints[[index]] <- constraint
+  list(constraints = constraints, added = TRUE)
+}
+
+# complementary constraint that should be added in case of abs
+absConstraint <- function(constraint){
+  lhs <- constraint$lhs
+  lhs[length(lhs)] <- lhs[length(lhs)] * -1
+  abs <- list(lhs = lhs,
+              dir = ifelse(constraint$dir == "<=", ">=", ifelse(constraint$dir == ">=", "<=", "==")),
+              rhs = constraint$rhs * (-1))
+}
+
+# creates constraints, for each j, for w_b - a_bj*w_j or for w_j-a_jw*w_w
+# first equation referes to the best-to-others vector, the second one to the others-to-worst vector
+createBaseModelConstraints <- function(model, constraints, vectorType, dir, rhs = 0, ksiIndexValue = 0){
+  assert(vectorType %in% c("best", "worst"), "vectorType should be either 'best' or 'worst'.")
+  vector <- if(vectorType == "best") model$bestToOthers else model$othersToWorst
+
+  # weight that has a number 1 on its index in the vector
+  # should be ommited
+  weightWithOneIndex <- match(1, vector)
+
+  # number of added constraints is
+  # useful for creating constraints opposite to these ones
+  numberOfAddedConstraints <-0
+
+  for(j in seq(length(vector))){
+    if(j != weightWithOneIndex){
+      lhs <- rep(0, length(vector) + 1)
+
+      if(vectorType == "best"){
+        # add w_b - a_bj*w_j = 0
+        lhs[weightWithOneIndex] <- 1
+        lhs[j] <- -vector[j]
+      } else {
+        # add w_j - a_jw*w_w = 0
+        lhs[weightWithOneIndex] <- -vector[j]
+        lhs[j] <- 1
+      }
+
+
+      lhs[model$ksiIndex] <- ksiIndexValue
+      result <- combineConstraints(constraints, list(lhs = lhs, dir = dir, rhs = rhs))
+      if(result$added){
+        constraints <- result$constraints
+        numberOfAddedConstraints <- numberOfAddedConstraints + 1
+      }
+    }
+  }
+  list(constraints = constraints, numberOfAddedConstraints = numberOfAddedConstraints)
+}
+
+#constraints for weights' sum and their minimal value (w >= 0)
+buildBasicConstraints <- function(model){
+  # n variables for weights, 1 for ksi index
+  numberOfVariables <- length(model$bestToOthers) + 1
+
+  lhs <- rep(0, numberOfVariables)
+  # sum up all weights to 1
+  lhs[1:length(lhs)-1] <- 1
+  dir <- "=="
+  rhs <- 1
+
+  constraints <- list()
+  constraints <- combineConstraints(constraints, list(lhs = lhs, dir = dir, rhs = rhs))$constraints
+  # all weights must be >= 0
+  for(j in seq(length(model$bestToOthers))){
+    lhs <- rep(0, numberOfVariables)
+    lhs[j] <- 1
+    constraints <- combineConstraints(constraints, list(lhs = lhs, direction = ">=", rhs = 0))$constraints
+  }
+  constraints
+}
+
+addConstraintsFromResult <- function(constraints, result){
+  if(result$numberOfAddedConstraints > 0){
+    constraints <- result$constraints
+    # add constraints that stem from removing abs
+    # take only result$numberOfAddedConstraints constraints that has just been added (there may have been some duplicates)
+    # and multiply them by -1
+    constraintsToScale <- tail(constraints, n=result$numberOfAddedConstraints)
+    lapply(constraintsToScale, function(x){
+      constraints <<- combineConstraints(constraints, absConstraint(x))$constraints # '<<-' refers to outer scope
+    })
+  }
+  constraints
+}
+
+constraintsListToMatrix <- function(constraints){
+  result <- list()
+  #format constraints
+  result$lhs <- t(sapply(constraints, function(x){
+    x$lhs
+  }))
+  result$dir <- sapply(constraints, function(x){
+    x$dir
+  })
+  result$rhs <- unlist(sapply(constraints, function(x){
+    x$rhs
+  }))
+  result
+}
+
+createModelsObjective <- function(model, objectiveIndex, objectiveValue = 1){
+  objective <- rep(0, length(model$bestToOthers) + 1)
+  objective[objectiveIndex] <- objectiveValue
+  objective
+}
+
+buildModel <- function(bestToOthers, othersToWorst, criteriaNames){
+  model <- validateData(bestToOthers, othersToWorst, criteriaNames)
+  consistency <- isConsistent(model)
+  model$isConsistent <- consistency$isConsistent
+  model$a_bw <- consistency$a_bw
+
+  #weights' sum and weights' limit value (w >= 0)
+  constraints <- buildBasicConstraints(model)
+
+  # ksi index
+  model$ksiIndex <- length(model$bestToOthers)+1
+
+  if(model$isConsistent){
+    #add best-to-others constraints
+    result <- createBaseModelConstraints(model, constraints, vectorType = "best", dir = "==")
+    if(result$numberOfAddedConstraints > 0){
+      constraints <- result$constraints
+    }
+  }  else {
+      #add best-to-others constraints
+      result <- createBaseModelConstraints(model, constraints, vectorType = "best", dir = "<=", ksiIndexValue = -1)
+      constraints <- addConstraintsFromResult(constraints, result)
+
+      #add others-to-worst constraints
+      result <- createBaseModelConstraints(model, constraints, vectorType = "worst", dir = "<=", ksiIndexValue = -1)
+      constraints <- addConstraintsFromResult(constraints, result)
+  }
+
+  model$constraints = constraintsListToMatrix(constraints)
+  model$objective <- createModelsObjective(model, model$ksiIndex)
+  #minimize objective's value by default
+  model$maximize <- FALSE
+
+  model
+}
@@ -0,0 +1,38 @@
+#' calculateWeights
+#'
+#' Implementation based on https://doi.org/10.1016/j.omega.2015.12.001.
+#' Calculates weights of the criteria using a linear model.
+#' Steps:
+#' 1. Build model (consists of validating model and constructing necessary constraints for LP problem).
+#' 2. Solve LP problem.
+#' 3. Calculate consistency ratio.
+#'
+#' @name calculateWeights
+#' @param criteriaNames Names of the criteria
+#' @param bestToOthers Vector of pairwise comparisons. Best criterion should be 1, others <2, 9>.
+#' @param othersToWorst Vector of pairwise comparisons. Worst criterion should be 1, others <2, 9>.
+#' @return Result that consist of \code{criteriaNames}, \code{criteriaWeights}, \code{consistencyRatio} and a model that was used to calculate weights.
+#' @examples
+#' criteriaNames <- c("quality", "price", "comfort", "safety", "style")
+#' bestToOthers <- c(2, 1, 4, 2, 8)
+#' othersToWorst <- c(4, 8, 2, 4, 1)
+#' calculateWeights(criteriaNames, bestToOthers, othersToWorst)
+#' @import Rglpk
+#' @export
+calculateWeights <- function(criteriaNames, bestToOthers, othersToWorst){
+  model <- buildModel(bestToOthers, othersToWorst, criteriaNames)
+  #const values that are listed in the article
+  consistencyIndex <- c(0, .44, 1.0, 1.63, 2.3, 3., 3.73, 4.47, 5.23)
+
+  #unique optimal solution
+  result <- solveLP(model)
+  weights <- result$solution[1:model$ksiIndex-1]
+  consistencyRatio <- result$solution[model$ksiIndex] / consistencyIndex[as.integer(model$a_bw)]
+
+  result <- list(criteriaNames = criteriaNames, criteriaWeights = weights, consistencyRatio = consistencyRatio)
+  list(result = result, model = model)
+}
+
+solveLP <- function(model){
+  Rglpk_solve_LP(model$objective, model$constraints$lhs, model$constraints$dir, model$constraints$rhs, max = model$maximize)
+}