Francisco Jesús Martínez Mimbrera
182 lines
7.2 KiB
R
182 lines
7.2 KiB
R
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
|
|
}
|