R/ahp_aggjudge.R

In ahpsurvey: Analytic Hierarchy Process for Survey Data

#' Aggregate individual judgments
#'
#' @author Frankie Cho
#'
#' @description Aggregate individual judgments 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 aggmethod The method of aggregating the judgments by all decision-makers. Five modes aggregation are available:  ``arithmetic``: the arithmetic mean; ``geometric``: the geometric mean (the default); ``rootmean``: the square root of the sum of the squared value, `tmean`: the trimmed mean, `tgmean`: trimmed geometric mean. The quantiles trimmed are based on `qt`. It can also be set to `sd`, where it reports the standard deviation from the arithmetic mean.
#' @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 pairwise judgments of all the decision-makers.
#'
#' @include ahp_mat.R
#' 
#' @examples
#'
#' ## Computes individual judgments with geometric mean and aggregates them
#' ## with a trimmed arithmetic mean
#'
#' data(city200)
#' atts <- c('cult', 'fam', 'house', 'jobs', 'trans')
#'
#' cityahp <- ahp.mat(df = city200, atts = atts, negconvert = TRUE)
#' ahp.aggjudge(cityahp, atts, aggmethod = 'tmean', qt = 0.1)
#'
#'
#'@export
ahp.aggjudge <- function(ahpmat, atts, aggmethod = "geometric", 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)])
    
    indpref <- list()
    indpref.df <- array(as.numeric(unlist(respmat)), dim = c(length(atts), length(atts), 
        length(respmat)))
    colnames(indpref.df) <- rownames(indpref.df) <- atts
    ## Normalise by column sums
    
    if (aggmethod == "arithmetic") {
        amethod <- mean
    } else if (aggmethod == "geometric") {
        amethod <- gm_mean
    } else if (aggmethod == "rootmean") {
        amethod <- root_mean
    } else if (aggmethod == "tmean") {
        amethod <- tmean
    } else if (aggmethod == "tgmean") {
        meanmethod <- tgmean
    } else if (aggmethod == "sd") {
        amethod <- sd
    } else {
        print("Method invalid!")
    }
    
    if (aggmethod == "tmean" | aggmethod == "tgmean") {
        aggpref <- apply(indpref.df, c(1, 2), amethod, qt = qt)
    } else {
        aggpref <- apply(indpref.df, c(1, 2), amethod)
    }
    colnames(aggpref) <- rownames(aggpref) <- atts
    aggpref
}

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