R/ahp_aggpref.R

In ahpsurvey: Analytic Hierarchy Process for Survey Data

#' Aggregate priority weights
#'
#' @author Frankie Cho
#'
#' @description Compute and aggregate individual priority weights from pairwise comparison matrices
#'
#' @param ahpmat A list of pairwise comparison matrices of each decision maker generated by `ahp.mat`.
#' @param atts a list of attributes in the correct order
#' @param method if `method = "eigen"`, the individual priority weights are computed using the Dominant Eigenvalues method described in \insertCite{Saaty2003;textual}{ahpsurvey}. Otherwise, then the priorities are computed based on the averages of normalized values. Basically it normalizes the matrices so that all of the columns add up to 1, and then computes the averages of the row as the priority weights of each attribute. Three modes of finding the averages are available:  ``arithmetic``: the arithmetic mean; ``geometric``: the geometric mean (the default); ``rootmean``: the square root of the sum of the squared value.
#' @param aggmethod how to aggregate the individual priorities. By default `aggmethod = method`. Apart from the methods offered in `method`, `aggmethod` also permits three other options: `tmean` computes the trimmed arithmetic mean, `tgmean` computes the trimmed geometric mean (both with quantiles trimmed based on `qt`), and `sd` computes the standard deviation from the arithmetic mean. If `method = "eigen"` and `aggmethod` is not specified, `aggmethod` defaults to `"geometric"`.
#' @param qt specifies the quantile which the top **and** bottom priority weights are trimmed. Used only if `aggmethod = 'tmean'` or `aggmethod = 'tgmean'`. For example, `qt = 0.25` specifies that the aggregation is the arithmetic mean of the values from the 25 to 75 percentile. By default `qt = 0`.
#'
#' @return A `data.frame` of the aggregated priorities of all the decision-makers.
#' @include ahp_mat.R
#'
#'
#' @examples
#'
#' ## Computes individual priorities with geometric mean and aggregates them
#' ## with a trimmed arithmetic mean
#'
#'library(magrittr)
#'
#' data(city200)
#' atts <- c('cult', 'fam', 'house', 'jobs', 'trans')
#'
#' cityahp <- ahp.mat(df = city200, atts = atts, negconvert = TRUE)
#' ahp.aggpref(cityahp, atts, method = 'geometric', aggmethod = 'tmean', qt = 0.1)
#'
#'@references
#'\insertAllCited{}
#'
#'@export

ahp.aggpref <- function(ahpmat, atts, method = "geometric", aggmethod = method, qt = 0) {
    respmat <- ahpmat
    qt <- qt
    
    stdmat <- list()
    for (ind in 1:length(respmat)) {
        stdmat[[ind]] <- scale(respmat[[ind]], center = FALSE, scale = colSums(respmat[[ind]]))
    }
    
    for (ind in 1:length(respmat)) attr(stdmat[[ind]], "scaled:scale") <- NULL
    
    gm_mean <- function(x, na.rm = TRUE) {
        exp(sum(log(x[x > 0]), na.rm = na.rm)/length(x))
    }
    
    root_mean <- function(x) sqrt(mean(x^2))
    
    tmean <- function(x, qt) mean(x[x > stats::quantile(x, qt) & x < stats::quantile(x, 
        1 - qt)])
    
    tgmean <- function(x, qt) gm_mean(x[x > stats::quantile(x, qt) & x < stats::quantile(x, 1 - qt)])
    
    if (method == "arithmetic") {
        meanmethod <- mean
    } else if (method == "geometric") {
        meanmethod <- gm_mean
    } else if (method == "rootmean") {
        meanmethod <- root_mean
    } else if (method == "eigen") {
    } else {
        print("Method invalid!")
    }
    
    if (method == "eigen") {
        indpref.df <- matrix(nrow = length(atts), ncol = length(respmat), data = NA)
        for (ind in 1:length(respmat)) {
            
            .iter <- list()
            .scale <- list()
            .norm <- list()
            
            .iter[[1]] <- rowSums(respmat[[ind]])/length(atts)
            .scale[[1]] <- .iter[[1]]/max(.iter[[1]])
            
            for (i in 1:11) {
                .iter[[i + 1]] <- respmat[[ind]] %*% .iter[[i]]
                .scale[[i + 1]] <- .iter[[i + 1]]/max(.iter[[i + 1]])
                .norm[[i + 1]] <- .scale[[i + 1]]/sum(.scale[[i + 1]])
            }
            indpref.df[, ind] <- .norm[[12]]
        }
        indpref.df <- as.data.frame(t(indpref.df))
        colnames(indpref.df) <- atts
    } else {
        indpref <- list()
        for (ind in 1:length(respmat)) indpref[[ind]] <- apply(stdmat[[ind]], 1, meanmethod)/sum(apply(stdmat[[ind]], 
            1, meanmethod))
        indpref.df <- data.frame(matrix(unlist(indpref), nrow = length(respmat), byrow = T), 
            stringsAsFactors = FALSE)
        colnames(indpref.df) <- atts
    }
    ## Normalise by column sums
    
    if (aggmethod == "arithmetic") {
        amethod <- mean
    } else if (aggmethod == "geometric"| aggmethod == "eigen") {
        amethod <- gm_mean
    } else if (aggmethod == "rootmean") {
        amethod <- root_mean
    } else if (aggmethod == "tmean") {
        amethod <- tmean
    } else if (aggmethod == "tgmean") {
      amethod <- tgmean
    } else if (aggmethod == "sd") {
        amethod <- stats::sd
    } else {
        stop("Method invalid!")
    }
    
    if (aggmethod == "tmean"| aggmethod == "tgmean") {
        aggpref <- apply(indpref.df, 2, amethod, qt = qt)
    } else {
        aggpref <- apply(indpref.df, 2, amethod)
    }
    names(aggpref) <- atts
    aggpref
}

if (getRversion() >= "2.15.1") utils::globalVariables(c("sd", "%>%", "count", "quantile"))