R/LPDMRSortIdentifyIncompatibleAssignments.R

In MCDA: Support for the Multicriteria Decision Aiding Process

#' Identifies all sets of assignment examples which are incompatible with the
#' MRSort sorting method extended to handle large performance differences.
#' 
#' MRSort is a simplified ElectreTRI method that uses the pessimistic
#' assignment rule, without indifference or preference thresholds attached to
#' criteria. LPDMRSort considers both a binary discordance and a binary
#' concordance conditions including several interactions between them. This
#' function outputs all (or a fixed number of) sets of incompatible assignment
#' examples ranging in size from the minimal size and up to a given threshold.
#' The retrieved sets are also not contained in each other.
#' 
#' 
#' @param performanceTable Matrix or data frame containing the performance
#' table.  Each row corresponds to an alternative, and each column to a
#' criterion.  Rows (resp. columns) must be named according to the IDs of the
#' alternatives (resp. criteria).
#' @param assignments Vector containing the assignments (IDs of the categories)
#' of the alternatives to the categories.  The elements are named according to
#' the alternatives.
#' @param categoriesRanks Vector containing the ranks of the categories.  The
#' elements are named according to the IDs of the categories.
#' @param criteriaMinMax Vector containing the preference direction on each of
#' the criteria.  "min" (resp. "max") indicates that the criterion has to be
#' minimized (maximized).  The elements are named according to the IDs of the
#' criteria.
#' @param majorityRule String denoting how the vetoes and dictators are
#' combined in order to form the assignment rule.  The values to choose from
#' are "M", "V", "D", "v", "d", "dV", "Dv", "dv".  "M" corresponds to using
#' only the majority rule without vetoes or dictators, "V" considers only the
#' vetoes, "D" only the dictators, "v" is like "V" only that a dictator may
#' invalidate a veto, "d" is like "D" only that a veto may invalidate a
#' dictator, "dV" is like "V" only that if there is no veto we may then
#' consider the dictator, "Dv" is like "D" only that when there is no dictator
#' we may consider the vetoes, while finally "dv" is identical to using both
#' dictator and vetoes only that when both are active they invalidate each
#' other, so the majority rule is considered in that case.
#' @param incompatibleSetsLimit Pozitive integer denoting the upper limit of
#' the number of sets to be retrieved.
#' @param largerIncompatibleSetsMargin Pozitive integer denoting whether sets
#' larger than the minimal size should be retrieved, and by what margin. For
#' example, if this is 0 then only sets of the minimal size will be retrieved,
#' if this is 1 then sets also larger by 1 element will be retrieved.
#' @param alternativesIDs Vector containing IDs of alternatives, according to
#' which the datashould be filtered.
#' @param criteriaIDs Vector containing IDs of criteria, according to which the
#' data should be filtered.
#' @return The function returns NULL if there is a problem, or a list
#' containing a list of incompatible sets of alternatives as vectors and the
#' status of the execution.
#' @references Bouyssou, D. and Marchant, T. An axiomatic approach to
#' noncompen-satory sorting methods in MCDM, II: more than two categories.
#' European Journal of Operational Research, 178(1): 246--276, 2007.
#' 
#' Meyer, P. and Olteanu, A-L. Integrating large positive and negative
#' performance differences in majority-rule sorting models. European Journal of
#' Operational Research, submitted , 2015.
#' @keywords methods
#' @examples
#' 
#' # the performance table
#' 
#' performanceTable <- rbind(c(10,10,9), c(10,9,10), c(9,10,10), c(9,9,10), 
#'                           c(9,10,9), c(10,9,9), c(10,10,7), c(10,7,10), 
#'                           c(7,10,10), c(9,9,17), c(9,17,9), c(17,9,9), 
#'                           c(7,10,17), c(10,17,7), c(17,7,10), c(7,17,10), 
#'                           c(17,10,7), c(10,7,17), c(7,9,17), c(9,17,7), 
#'                           c(17,7,9), c(7,17,9), c(17,9,7), c(9,7,17), 
#'                           c(7,7,7))
#' 
#' rownames(performanceTable) <- c("a1", "a2", "a3", "a4", "a5", "a6", "a7", 
#'                                 "a8", "a9", "a10", "a11", "a12", "a13", 
#'                                 "a14", "a15", "a16", "a17", "a18", "a19", 
#'                                 "a20", "a21", "a22", "a23", "a24", "a25")
#' 
#' colnames(performanceTable) <- c("c1","c2","c3")
#' 
#' assignments <-rbind(c("P","P","P","F","F","F","F","F","F","F","F","F",
#'                     "F","F","F","F","F","F","F","F","F","F","F","F","P"), 
#'                     c("P","P","P","F","F","F","P","P","P","P","P","P",
#'                     "P","P","P","P","P","P","P","P","P","P","P","P","P"), 
#'                     c("P","P","P","F","F","F","F","F","F","F","F","F",
#'                     "P","P","P","P","P","P","F","F","F","F","F","F","P"), 
#'                     c("P","P","P","F","F","F","P","P","P","P","P","P",
#'                     "P","P","P","P","P","P","F","F","F","F","F","F","P"), 
#'                     c("P","P","P","F","F","F","F","F","F","P","P","P",
#'                     "F","F","F","F","F","F","F","F","F","F","F","F","P"), 
#'                     c("P","P","P","F","F","F","F","F","F","P","P","P",
#'                     "P","P","P","P","P","P","P","P","P","P","P","P","P"), 
#'                     c("P","P","P","F","F","F","F","F","F","P","P","P",
#'                     "P","P","P","P","P","P","F","F","F","F","F","F","P"))
#' 
#' colnames(assignments) <- rownames(performanceTable)
#' 
#' categoriesRanks <-c(1,2)
#' 
#' names(categoriesRanks) <- c("P","F")
#' 
#' criteriaMinMax <- c("max","max","max")
#' 
#' names(criteriaMinMax) <- colnames(performanceTable)
#' 
#' majorityRules <- c("V","D","v","d","dV","Dv","dv")
#' 
#' for(i in 1:1)# change to 7 in order to perform all tests
#' {
#'   incompatibleAssignmentsSets<-LPDMRSortIdentifyIncompatibleAssignments(
#'                                  performanceTable, assignments[i,], 
#'                                  categoriesRanks, criteriaMinMax,
#'                                  majorityRule = majorityRules[i])
#'   
#'   filteredAlternativesIDs <- setdiff(rownames(performanceTable),
#'                                      incompatibleAssignmentsSets[[1]][1])
#'   
#'   x<-LPDMRSortInferenceExact(performanceTable, assignments[i,], 
#'                              categoriesRanks, criteriaMinMax, 
#'                              majorityRule = majorityRules[i], 
#'                              readableWeights = TRUE, 
#'                              readableProfiles = TRUE, 
#'                              minmaxLPD =  TRUE, 
#'                              alternativesIDs = filteredAlternativesIDs)
#'   
#'   ElectreAssignments<-LPDMRSort(performanceTable, x$profilesPerformances, 
#'                                 categoriesRanks,
#'                                 x$weights, criteriaMinMax, x$lambda, 
#'                                 criteriaVetos=x$vetoPerformances,
#'                                 criteriaDictators=x$dictatorPerformances, 
#'                                 majorityRule = majorityRules[i],
#'                                 alternativesIDs = filteredAlternativesIDs)
#'   
#'   print(all(ElectreAssignments == assignments[i,filteredAlternativesIDs]))
#' }
#' 
#' @export LPDMRSortIdentifyIncompatibleAssignments
LPDMRSortIdentifyIncompatibleAssignments <- function(performanceTable, assignments, categoriesRanks, criteriaMinMax, majorityRule = "M", incompatibleSetsLimit = 100, largerIncompatibleSetsMargin = 0, alternativesIDs = NULL, criteriaIDs = NULL){
  
  ## check the input data
  if (!((is.matrix(performanceTable) || (is.data.frame(performanceTable))))) 
    stop("wrong performanceTable, should be a matrix or a data frame")
  
  if (!(is.vector(assignments)))
    stop("assignments should be a vector")
  
  if (!(is.vector(categoriesRanks)))
    stop("categoriesRanks should be a vector")
  
  if (!(is.vector(criteriaMinMax)))
    stop("criteriaMinMax should be a vector")
  
  if (!is.character(majorityRule))
    stop("majorityRule should be a string")
  else if (!(majorityRule %in% c("M","V","D","v","d","dV","Dv","dv")))
    stop("majorityRule needs to take values in {'M','V','D','v','d','dV','Dv','dv'}")
  
  if (!is.numeric(incompatibleSetsLimit))
    stop("incompatibleSetsLimit should be numeric")
  else if (incompatibleSetsLimit%%1!=0)
    stop("incompatibleSetsLimit should be an integer")
  else if (incompatibleSetsLimit<=0)
    stop("incompatibleSetsLimit should be strictly pozitive")
  
  if (!is.numeric(largerIncompatibleSetsMargin))
    stop("largerIncompatibleSetsMargin should be numeric")
  else if (largerIncompatibleSetsMargin%%1!=0)
    stop("largerIncompatibleSetsMargin should be an integer")
  else if (largerIncompatibleSetsMargin<0)
    stop("largerIncompatibleSetsMargin should be pozitive")
  
  if (!(is.null(alternativesIDs) || is.vector(alternativesIDs)))
    stop("alternativesIDs should be a vector")
  
  if (!(is.null(criteriaIDs) || is.vector(criteriaIDs)))
    stop("criteriaIDs should be a vector")
  
  ## filter the data according to the given alternatives and criteria
  
  if (!is.null(alternativesIDs)){
    performanceTable <- performanceTable[alternativesIDs,]
    assignments <- assignments[alternativesIDs]
  }
  else
    alternativesIDs = rownames(performanceTable)
  
  if (!is.null(criteriaIDs)){
    performanceTable <- performanceTable[,criteriaIDs]
    criteriaMinMax <- criteriaMinMax[criteriaIDs]
  }
  else
    criteriaIDs = colnames(performanceTable)
  
  # data is filtered, check for some data consistency
  
  # if there are less than 2 criteria or 2 alternatives, there is no MCDA problem
  
  if (is.null(dim(performanceTable))) 
    stop("less than 2 criteria or 2 alternatives")
  
  # -------------------------------------------------------
  
  numCrit <- dim(performanceTable)[2]
  
  numAlt <- dim(performanceTable)[1]
  
  numCat <- length(categoriesRanks)
  
  tempPath <- tempdir()
  
  # get data content that remains the same for all following linear program executions
  
  datacontent <- paste("data;\nparam X := ", numAlt, ";\n\nparam F := ", numCrit, ";\n\nparam Fdir := \n", sep = "")
  
  for (i in 1:numCrit){
    datacontent <- paste(datacontent, i, "\t", sep = "")
    if (criteriaMinMax[i]=="min")
      datacontent <- paste(datacontent, "-1", sep = "")
    else
      datacontent <- paste(datacontent, "1", sep = "")
    if (i!=numCrit)
      datacontent <- paste(datacontent, "\n", sep = "")
    else
      datacontent <- paste(datacontent, ";\n\n", sep = "")
  }
  
  datacontent <- paste(datacontent, "param Fmin :=\n", sep = "")
  
  for (i in 1:numCrit){
    datacontent <- paste(datacontent, i, "\t", apply(performanceTable, 2, min)[i], sep = "")
    if (i!=numCrit)
      datacontent <- paste(datacontent, "\n", sep = "")
    else
      datacontent <- paste(datacontent, ";\n\n", sep = "")
  }
  
  datacontent <- paste(datacontent, "param Fmax :=\n", sep = "")
  
  for (i in 1:numCrit){
    datacontent <- paste(datacontent, i, "\t", apply(performanceTable, 2, max)[i], sep = "")
    if (i!=numCrit)
      datacontent <- paste(datacontent, "\n", sep = "")
    else
      datacontent <- paste(datacontent, ";\n\n", sep = "")
  }
  
  datacontent <- paste(datacontent, "param K :=", numCat, ";\n\n", sep = "")
  
  datacontent <- paste(datacontent, "param A:=\n", sep = "")
  
  for (i in 1:numAlt){
    datacontent <- paste(datacontent, i, "\t", categoriesRanks[assignments[i]], sep = "")
    if (i!=numAlt)
      datacontent <- paste(datacontent, "\n", sep = "")
    else
      datacontent <- paste(datacontent, ";\n\n", sep = "")
  }
  
  datacontent <- paste(datacontent, "param PTx : ", sep = "")
  for(i in 1:numCrit)
    datacontent <- paste(datacontent, i, sep = " ")
  datacontent <- paste(datacontent, ":= \n", sep = "")
  
  
  for (i in 1:numAlt){
    datacontent <- paste(datacontent, i, "\t", sep = "")
    for (j in 1:numCrit){
      datacontent <- paste(datacontent, performanceTable[i,j], sep = "")
      if (j!=numCrit)
        datacontent <- paste(datacontent, " ", sep = "")
    }
    if (i!=numAlt)
      datacontent <- paste(datacontent, "\n", sep = "")
    else
      datacontent <- paste(datacontent, ";\n\n", sep = "")
  }
  
  datacontent <- paste(datacontent, "param gamma:=0.0001;\n", sep = "")
  
  # get first model file
  
  modelfilename <- paste("MRSort", c("","V","D","DV1","DV2","DV3","DV4","DV5")[match(majorityRule,c("M","V","D","v","d","dV","Dv","dv"))], "IdentifyMinimalInvalidAssignmentsSet.gmpl", sep = "")
  
  modelFile <- system.file("extdata",modelfilename, package="MCDA")
  
  # write data file
  
  dataFile <- tempfile()
  
  file.copy(modelFile, dataFile)
  
  sink(dataFile, append=TRUE)
  
  cat(datacontent)
  
  cat("end;\n")
  
  sink()
  
  # init and run linear program
  
  lp<-initProbGLPK()
  
  tran<-mplAllocWkspGLPK()
  
  setMIPParmGLPK(PRESOLVE, GLP_ON)
  
  termOutGLPK(GLP_OFF)
  
  out<-mplReadModelGLPK(tran, dataFile, skip=0)
  
  if (is.null(out))
    out <- mplGenerateGLPK(tran)
  else 
    stop(return_codeGLPK(out))
  
  if (is.null(out))
    mplBuildProbGLPK(tran,lp)
  else 
    stop(return_codeGLPK(out))
  
  solveMIPGLPK(lp)
  
  if(mipStatusGLPK(lp)==5){
    
    mplPostsolveGLPK(tran, lp, sol = GLP_MIP)
    
    solution <- mipColsValGLPK(lp)
    
    varnames <- c()
    
    for (i in 1:length(solution))
      varnames <- c(varnames,getColNameGLPK(lp,i))
    
    paro <- "["
    parc <- "]"
    
    error <- FALSE
  }
  
  if (!error){
    
    # get size of minimal incompatible assignments set and one such set
    
    minIncompatibleSetsSize <- 0
    
    incompatibleSet <- c()
    
    for (i in 1:numAlt)
    {
      if(solution[varnames==paste("OnOff",paro,i,parc,sep="")] == 1)
      {
        incompatibleSet <- c(incompatibleSet,alternativesIDs[i])
        minIncompatibleSetsSize <- minIncompatibleSetsSize + 1
      }
    }
    
    incompatibleSets <- list(incompatibleSet)
    
    # if there are no incompatible sets return the empty set
    
    if(minIncompatibleSetsSize == 0)
      return(incompatibleSets)
    
    # get second model file
    
    modelfilename <- paste("MRSort", c("","V","D","DV1","DV2","DV3","DV4","DV5")[match(majorityRule,c("M","V","D","v","d","dV","Dv","dv"))], "IdentifyInvalidAssignmentsSet.gmpl", sep = "")
    
    modelFile <- system.file("extdata",modelfilename, package="MCDA")
    
    # create new data content
    
    datacontent2a <- "param PrevOnOff : "
    for(i in 1:numAlt)
      datacontent2a <- paste(datacontent2a, i, sep = " ")
    datacontent2a <- paste(datacontent2a, ":= \n1\t", sep = "")
    for(i in 1:numAlt)
      datacontent2a <- paste(datacontent2a, solution[varnames==paste("OnOff",paro,i,parc,sep="")], sep = " ")
    
    datacontent2b <- paste("param PrevOnOffLimit := \n1\t ", minIncompatibleSetsSize, sep ="")
    
    # iterate through acceptes sizes for incompatible assignment sets
    
    incompatibleSetSize <- minIncompatibleSetsSize
    
    while(incompatibleSetSize <= minIncompatibleSetsSize + largerIncompatibleSetsMargin)
    {
      # break if we've retrieved the desired number of incompatible sets
      
      if(length(incompatibleSets) >= incompatibleSetsLimit)
        break
      
      repeat{
        # write data file
        
        dataFile <- tempfile()
        
        file.copy(modelFile, dataFile)
        
        sink(dataFile, append=TRUE)
        
        cat(datacontent)
        
        cat("param invalid:=")
        cat(incompatibleSetSize)
        cat(";\n")
        
        cat("param Y:=")
        cat(length(incompatibleSets))
        cat(";\n")
        
        cat(datacontent2a)
        cat(";\n\n")
        
        cat(datacontent2b)
        cat(";\n\n")
        
        cat("end;\n")
        
        sink()
        
        # init and run linear program
        
        lp<-initProbGLPK()
        
        tran<-mplAllocWkspGLPK()
        
        setMIPParmGLPK(PRESOLVE, GLP_ON)
        
        termOutGLPK(GLP_OFF)
        
        out<-mplReadModelGLPK(tran, dataFile, skip=0)
        
        if (is.null(out))
          out <- mplGenerateGLPK(tran)
        else 
          stop(return_codeGLPK(out))
        
        if (is.null(out))
          mplBuildProbGLPK(tran,lp)
        else 
          stop(return_codeGLPK(out))
        
        
        
        solveMIPGLPK(lp)
        
        error <- TRUE
        
        if(mipStatusGLPK(lp)==5){
          
          mplPostsolveGLPK(tran, lp, sol = GLP_MIP)
          
          solution <- mipColsValGLPK(lp)
          
          varnames <- c()
          
          for (i in 1:length(solution))
            varnames <- c(varnames,getColNameGLPK(lp,i))
          
          paro <- "["
          parc <- "]"
          
          error <- FALSE
        }
        
        
        
        if (!error){
          
          # get incompatible assignments set
          
          incompatibleSet <- c()
          
          for (i in 1:numAlt)
            if(solution[varnames==paste("OnOff",paro,i,parc,sep="")] == 1)
              incompatibleSet <- c(incompatibleSet,alternativesIDs[i])
          
          # add set
          
          incompatibleSets <- c(incompatibleSets, list(incompatibleSet))
          
          # update data content
          
          datacontent2a <- paste(datacontent2a, "\n", length(incompatibleSets), "\t", sep = "")
          for(i in 1:numAlt)
            datacontent2a <- paste(datacontent2a, solution[varnames==paste("OnOff",paro,i,parc,sep="")], sep = " ")
          
          datacontent2b <- paste(datacontent2b, "\n", length(incompatibleSets), "\t", incompatibleSetSize, sep ="")
          
        }
        else
          break
      }
      
      # increase size of incompatible sets
      
      incompatibleSetSize <- incompatibleSetSize + 1
    }
    
    return(list(incompatibleSets = incompatibleSets, solverStatus = 'Success'))
    
  }
  else
    return(list(solverStatus = 'Failed'))
}