R/ranking.R

In noeliarico/consensus: A package for ranking rules in the field of social choice theory

#' Create ranking from vector
#' 
#' Given a numeric vector, the default behavior creates a ranking in 
#' ascending value. This is, the lower the value of the vector the better the 
#' candidate is considered.
#' If names are given in the vector they will be used as names of the 
#' candidates, to overwrite them, use the argument `cnames`.
#'
#' @param v   vector to be translated to a ranking.
#' @param cnames  names of the candidates. The values in this vector cannot
#' must identified uniquely each candidate, thus, repeated values are not 
#' allowed. 
#' @param desc Default is FALSE. Therefore the rankings are creating in 
#' ascending value
#'
#' @family ranking
#' @export
ranking <- function(v, cnames = NULL, desc = FALSE) {
  
  # Validate the parameters ----------------------------------------------------
  
  if(!is.null(cnames) && !is.vector(cnames)) {
    stop("The argument cnames must be a vector")
  }
  
  if(is.numeric(v)) {
    
    # Validate v ---------------------------------------------------------------
    has_names <- FALSE
    
    # A vector containing the names of the candidates given in cnames.
    # If it is valid, it will be assigned as the names of the candidates.
    # To be valid, all the values in cnames must be unique.
    # Also, it must be one name for each candidate.
    # If the v vector had names they will be ignored.
    if(!is.null(cnames)) {
      if(!is.vector(cnames)) {
        warning("cnames argument must be a vector")
      }
      else {
        if(!is.character(cnames)) {
          cnames <- as.character(cnames)
        }
        if(length(unique(cnames)) != length(cnames) || # different name
           length(cnames) != length(v)) { # one for each candidate
          warning("The values of cnames have been ignored because the name
                of each candidate must be unique.
                Default names has been autogenerated")
        }
        else {
          candidates_names <- cnames
          has_names <- TRUE
        }
      }
    }
    # If we are here it means that there are not valid names specified in n
    # or they are not given.
    # Now we have two different options. These are, if the vector v has or
    # hasn't names. If it has names and the names are valid they are used. If it
    # doesn't have names or they are invalid default names are given
    
    if(!is.null(names(v)) && !has_names) {
      
      candidates_names <- names(v)
      
      # all the candidates must have a different name
      # if the names of the vector are not suitable for the names of the
      # candidates a warning message is send and automatic values will be created
      if(length(unique(candidates_names)) != length(candidates_names)) {
        names(v) <- NULL
        warning("The names of the v vector
                  must be unique for each candidate.
                Default names has been autogenerated to
                accomplish this requirement.")
      }
      else {
        # the names of the vector are keeped
        has_names <- TRUE
      }
    }
    
    # if the vector does not have names and the param n is null, then the method
    # gives a name to each candidate with the format C1, C2, C3...
    if(!has_names) {
      candidates_names <- 1:length(v)
      candidates_names <- paste("C", candidates_names, sep = "")
    }
    
    names(v) <- candidates_names
    
    # Create the ranking -------------------------------------------------------
    
    # If there are not ties, the position of the element in the ranking is
    # the same that in the sorted vector.
    # If there are ties it is necessary to evaluate them element by element
    
    # Create the vector that will store the final ranking
    ranking <- rep(0, length(v))
    names(ranking) <- candidates_names
    
    # Sort the vector with the given criteria (ascending or descending)
    v <- sort(v, decreasing = desc)
    
    if(length(v) != length(unique(v))) {
      
      ordv <- rep(0, length(v))
      names(ordv) <- names(v)
      
      pos_ranking <- 1
      ordv[1] <- pos_ranking
      previous_elem <- v[1]
      for(index in 2:length(v)) {
        this_elem <- v[index]
        if(desc) {
          if(this_elem < previous_elem) {
            pos_ranking <- pos_ranking + 1
          }
        }
        else { # it can't be less cause they're ordered so this means it's equal
          if(this_elem > previous_elem) {
            pos_ranking <- pos_ranking + 1
          }
        }
        ordv[index] <- pos_ranking
        previous_elem <- v[index]
      }
      
      # ahora tengo que hacer coincidir el vector del ranking con la posición
      # original basándome en los nombres de las columnas
      indexes <- match(names(ordv), candidates_names)
      
      i <- 1
      for(elem in indexes) {
        ranking[elem] <- ordv[i]
        i <- i + 1
      }
      
    } # end of how to order if the vector has ties
    else { # no ties
      ordv <- 1:length(v)
      names(ordv) <- names(v)
      ranking <- match(candidates_names, names(ordv))
      names(ranking) <- candidates_names
    } # end of how to order if the vector has not ties
    # Recorro el vector, sustituyo el mejor número por un 1, que es la posición
    # continúo y sustituyo el número real por la misma posición si es igual al
    # de la posición anterior y si no incremento y luego sustituyo
  } # end of is.nuemric
  
  else if(is.character(v)) {
    # Validate unique candidates -----------------------------------------------
    ranking <- 1:length(v)
    # validate that the names are unique and if they are not: error
    names(ranking) <- v
  }
  
  else {
    stop("The first argument must be a vector.")
  }
  
  class(ranking) <- c("ranking", "numeric")
  return(ranking)
}

#' Translate ranking 
#' 
#' Parses a ranking from a graphical format to its R representation
#'
#' @param string  Graphical representation of the ranking
#' 
#' @family ranking
#' 
#' @return
#' @export
parse_ranking <- function(string) {
  
  # Valid symbols to express succ and sim
  succ <- c("\u227B", ">")
  sim <- c("\u223C", "\u007E", "=")
  symbols <- paste(paste(succ, collapse = "|"), 
             paste(sim, collapse = "|"), sep = "|")
  
  # Remove all the blank spaces
  string <- stringr::str_replace_all(string, " ", "")
  # Get the list of candidates splitting by the operators
  candidates <- unlist(strsplit(string, symbols))
  # Get the names of the candidates removing the operators
  candidates_names <- candidates[!candidates %in% symbols]
  # Count the number of candidates
  number_of_candidates <- length(candidates_names)
  # Vector of zeros (one per candidate) that will store the final ranking
  ranking <- integer(number_of_candidates)
  # Name the vector
  names(ranking) <- candidates_names
  operators <- unlist(strsplit(string, ""))
  operators <- operators[operators %in% c(succ, sim)]
  
  i <- 1
  pos <- 1
  ranking[i] <- 1

  for (elem in operators) {
    i <- i + 1
    if(elem %in% succ) {
      pos <- pos + 1
    }
    ranking[i] <- pos
  }
  
  ranking <- ranking[order(names(ranking))]
  
  class(ranking) <- c("ranking", "numeric")
  return(ranking)
}

#' Ranking has ties
#' 
#' Check whether the ranking object given as parameter has ties.
#'
#' @param ranking  Object of class ranking.
#'
#' @return TRUE if the ranking has ties, FALSE otherwise.
#' @export
ranking_has_ties <- function(ranking) {
  return(is.ranking(ranking) && (length(unique(ranking)) < length(ranking)))
}

#' Ranking to lineal
#' 
#' Take a ranking that contains ties and give a linear extension of the ranking
#' without ties.
#'
#' @param ranking  Object of the class ranking.
#'
#' @return Linear extension of the ranking given as parameter
#' @export
ranking_to_linear <- function(ranking) {
  if(!ranking_has_ties(ranking)) {
    warning("This ranking do not have ties")
    return(ranking)
  }
    
  m <- max(ranking)
  i <- 1
  for(iter in 1:m) {
    indexes <- which(ranking == i)
    if(length(indexes) > 1) { # there are tied candidates
      # Increment all the candidates that are later on the ranking
      ranking[ranking > i] <- ranking[ranking > i] + (length(indexes)-1)
      # Untie
      values <- i + 0:(length(indexes)-1)
      ranking[indexes] <- values
      # Update
      i <- i + (length(indexes)-1)
    }
    else {
      i <- i + 1
    }
  }
  return(ranking)
}

################################################################################
################################################################################

#' Check if the object is a ranking
#' 
#' @param x Object to check whether is a ranking
#' @param ... Any other parameter will be ignored
#'
#' @return TRUE if the object given as parameter is a ranking. FALSE otherwise.
#' 
#' @export
is.ranking <- function(x, ...) {
  
  if(length(x) == 1 && x == 1) {
    return(TRUE)
  }
  
  #if(length(unique(names(x))) == length(x)){
  max_pos <- max(x)
  min_pos <- min(x)
  if(min_pos > 0 && max_pos > 0 &&
     max_pos <= length(x) && min_pos < length(x) &&
     all(x <= max_pos) && all(x >= min_pos) &&
     all(1:max_pos %in% x)) {
    #if(inherits(x, "ranking")) {
    return(TRUE)
    #}
  }
  else {
    # message("The vector is not a ranking")
    return(FALSE)
  }
  #}
  
}

#' @method format ranking
#' @export
format.ranking <- function(x, ..., max.print = 9, latex = FALSE) {
  
  if(length(x) == 1){
    return(names(x))
  }
  
  ranking <- sort(x)
  
  names <- as.character(names(ranking))
  gr <- names[1]
  if(max.print > 0 && length(x) >= 9) {
    max <- max.print
  } else {
    max <- length(ranking)-1
  }
  for(i in 1:max) {
    thisElem <- ranking[i]
    nextElem <- ranking[i+1]
    
    if(thisElem<nextElem) {
      if(latex) {
        gr <- paste(gr, '\\succ',names[i+1])
      } else {
        if(Sys.info()['sysname'] != "Windows") {
          gr <- paste(gr, '\u227B',names[i+1])
        }
        else {
          gr <- paste(gr, '>', names[i+1]) 
        }
      }
      #gr <- paste(gr, '&#227B',names[i+1])
    }
    else { # this means the two rankings are equals
      if(latex) {
        gr <- paste(gr, '\\sim',names[i+1])
      } else {
        gr <- paste(gr, '\u223C',names[i+1])
      }
      #gr <- paste(gr, '&#007E',names[i+1])
    }
  }
  
  if(max < (length(ranking)-1)) {
    gr <- paste(gr, "...")
  }
  
  if(latex) {
    gr <- paste0("$$", gr, "$$")
  }
  
  return(gr)
}

#' @method print ranking
#' @export
print.ranking <- function(x, ..., latex = FALSE) {
  r <- format.ranking(x, latex)
  cat(r, "\n")
  #NextMethod() # for calling the print of the next class which is the vector
  invisible(r)
}

#' @export
default.ranking <- function(ranking, ...) {
  stop("Error: method not defined for the class ranking")
}