AHP
Pilar
2023-02-28
Proceso de jerarquía analítica para datos de encuestas
enR
Posteriormente, cargamos los datos necesarios,
city200que consisten en datos generados aleatoriamente de
200 individuos en función de los pesos proporcionados en Saaty (2004) .
La metodología de generación de datos se explica al final de esta
viñeta. (———. 2004. "Toma de decisiones: la jerarquía analítica y los
procesos de red (Ahp/Anp)". Revista de ciencia de sistemas e
ingeniería de sistemas 13 (1): 1–35. https://doi.org/10.1007/s11518-006-0151-5 .)
library(magrittr)## Warning: package 'magrittr' was built under R version 4.2.2library(dplyr)## Warning: package 'dplyr' was built under R version 4.2.2##
## Attaching package: 'dplyr'## The following objects are masked from 'package:stats':
##
## filter, lag## The following objects are masked from 'package:base':
##
## intersect, setdiff, setequal, unionlibrary(Rdpack)## Warning: package 'Rdpack' was built under R version 4.2.2library(randomNames)## Warning: package 'randomNames' was built under R version 4.2.2library(rbibutils)## Warning: package 'rbibutils' was built under R version 4.2.2library(ahpsurvey)
atts <- c("cult", "fam", "house", "jobs", "trans")
data(city200)
head(city200)## cult_fam cult_house cult_jobs cult_trans fam_house fam_jobs fam_trans
## 1 2 -2 2 -6 -4 -4 -8
## 2 2 -4 1 -4 -4 -2 -8
## 3 4 -2 1 -3 -7 -3 -5
## 4 8 -4 3 -4 -8 1 -7
## 5 3 -3 5 -6 -8 1 -4
## 6 6 -4 2 -4 -7 -2 -4
## house_jobs house_trans jobs_trans
## 1 4 -3 -8
## 2 4 -3 -7
## 3 4 -3 -6
## 4 4 -3 -9
## 5 4 -3 -6
## 6 4 -3 -6library(magrittr)
library(dplyr)
library(Rdpack)
library(randomNames)
library(rbibutils)
library(ahpsurvey)
city200%>%
ahp.mat(atts = atts, negconvert = TRUE) %>%
head(3)## [[1]]
## cult fam house jobs trans
## cult 1.0000000 0.500 2.0000000 0.500 6
## fam 2.0000000 1.000 4.0000000 4.000 8
## house 0.5000000 0.250 1.0000000 0.250 3
## jobs 2.0000000 0.250 4.0000000 1.000 8
## trans 0.1666667 0.125 0.3333333 0.125 1
##
## [[2]]
## cult fam house jobs trans
## cult 1.00 0.500 4.0000000 1.0000000 4
## fam 2.00 1.000 4.0000000 2.0000000 8
## house 0.25 0.250 1.0000000 0.2500000 3
## jobs 1.00 0.500 4.0000000 1.0000000 7
## trans 0.25 0.125 0.3333333 0.1428571 1
##
## [[3]]
## cult fam house jobs trans
## cult 1.0000000 0.2500000 2.0000000 1.0000000 3
## fam 4.0000000 1.0000000 7.0000000 3.0000000 5
## house 0.5000000 0.1428571 1.0000000 0.2500000 3
## jobs 1.0000000 0.3333333 4.0000000 1.0000000 6
## trans 0.3333333 0.2000000 0.3333333 0.1666667 1Pesos de preferencia individuales
El código a presentar realiza un análisis de proceso analítico jerárquico de una matriz de decisión llamada “city200” en R
En primer lugar, se realiza el análisis AHP utilizando la función ahp.mat del paquete ahp, que tomo como matriz de decisión a city200 y el vector atts de nombres de la columna como argumentos.
Negconver=T, para convertir los valores negativos en positivos en la matriz.
Se calculan las preferencias indivuales utilizando los métodos eigen y arithmetic con las funciones ahp.indpref. Los resultados de los métodos se comparaan para calcular el eror utilizando la diferencia máxima entre las dos matrices utilizando la función apply
library(ggplot2)## Warning: package 'ggplot2' was built under R version 4.2.2#Diferencia máxima de entre valor propio y agregación media
cityahp<-city200%>%ahp.mat(atts,negconvert = T)
eigentrue<-ahp.indpref(cityahp,atts,method = "eigen")
geom<-ahp.indpref(cityahp,atts,method ="arithmetic" )
error<-data.frame(id=1:length(cityahp), maxdiff=apply(abs(eigentrue-geom),1,max))
error%>%
ggplot(aes(x = id, y = maxdiff)) +
geom_point() +
geom_hline(yintercept = 0.05, linetype = "dashed", color = "red") +
geom_hline(yintercept = 0, color = "gray50") +
scale_x_continuous("Respondent ID") +
scale_y_continuous("Maximum difference") +
theme_minimal() 
Interpretación:
La linea roja indica un umbral de diferencia máximo aceptable (0.05) y la distancia entte los resultados de los métodos está por encima del umbral significa que es signnifiativo.
Se considera que existe diferencia signnificativa entre los resultados obtennidos con ambos métodos.
El código ha mostrar calcula la matriz de preferencias agregadas utilizando el método de agregación aritmética. La matriz de preferencias agregadas es una matriz que resume las preferencias de todos los evaluadores en una sola matriz. Esto se hace para poder obtener un ranking de las alternativas evaluadas, lo que facilita la toma de decisiones.
amean<-ahp.aggpref(cityahp,atts, method = "arithmetic")
amean## cult fam house jobs trans
## 0.16200828 0.43673193 0.07607178 0.28274933 0.04243868library(ggplot2)
library(tidyr)##
## Attaching package: 'tidyr'## The following object is masked from 'package:magrittr':
##
## extract#se crea una matriz vacía con 50 filas y 5 columnas para almacenar los resultados de los pesos de los criterios.
qtresults <- matrix(nrow = 50, ncol = 5, data = NA)
for (q in 1:50){
qtresults[q,] <- ahp.aggpref(cityahp, atts, method = "arithmetic",
aggmethod = "tmean", qt = (q-1)/100)
}
colnames(qtresults) <- atts
qtresults %>%
as.data.frame() %>%
mutate(trimperc = 1:nrow(qtresults)-1) %>%
mutate(cult = cult - amean[1],
fam = fam - amean[2],
house = house - amean[3],
jobs = jobs - amean[4],
trans = trans - amean[5]) %>%
gather(cult, fam, house, jobs, trans, key = "att", value = "weight") %>%
ggplot(aes(x = trimperc, y = weight, group = att, shape = att, color = att, fill = att)) +
geom_line() +
geom_point() +
scale_x_continuous("el percentil superior e inferior recortado") +
scale_y_continuous("el cambio del promedio no recortado") +
geom_hline(yintercept = 0, color = "gray") +
theme_minimal()
Cambios de ponderaciones agregadas en función del cuantil de datos recortados
library(knitr)
mean <- city200 %>%
ahp.mat(atts = atts, negconvert = TRUE) %>%
ahp.aggpref(atts, method = "arithmetic")
sd <- city200 %>%
ahp.mat(atts = atts, negconvert = TRUE) %>%
ahp.aggpref(atts, method = "arithmetic", aggmethod = "sd")
t(data.frame(mean, sd))%>% kable()| cult | fam | house | jobs | trans | |
|---|---|---|---|---|---|
| mean | 0.1620083 | 0.4367319 | 0.0760718 | 0.2827493 | 0.0424387 |
| sd | 0.0333849 | 0.0544975 | 0.0088232 | 0.0482966 | 0.0074665 |
city200 %>%
ahp.mat(atts = atts, negconvert = TRUE) %>%
ahp.aggjudge(atts, aggmethod = "geometric")## cult fam house jobs trans
## cult 1.0000000 0.2202027 3.0925191 0.4882218 4.638350
## fam 4.5412708 1.0000000 6.4612364 1.7035125 6.145824
## house 0.3233610 0.1547691 1.0000000 0.2488201 2.926539
## jobs 2.0482496 0.5870224 4.0189678 1.0000000 7.039173
## trans 0.2155939 0.1627121 0.3417005 0.1420621 1.000000Medición de la consistencia
weight<-c(5,-3,-2,-5,7,-1,-7,4,-3,-7)
sample_mat<-ahp.mat(t(weight),atts,negconvert = TRUE)
(cr_Std<-ahp.cr(sample_mat,atts ))## [1] 0.6331181Indicaría que la matriz de comparación de pesos no es completamente consistente. La AHP considera que una matriz es consistente si el CI es menor o igual a 0.1. Por lo tanto, en este caso, un valor de 0.63, sugiere que la matriz de comparación de pesos puede requerir ajustes o correcciones para ser completamente consistente.
cr<-city200%>%ahp.mat(atts,negconvert = T)%>%ahp.cr(atts)
table(cr<=0.1)##
## FALSE TRUE
## 70 130Esta salida significa que de todas las comparaciones en la matriz de
pesos city200, hay 70 comparaciones que
tienen un índice de consistencia mayor que 0.1 (es decir, se consideran
consistentes) y hay 130 comparaciones que tienen un índice de
consistencia menor o igual a 0.1 (es decir, se consideran inconsistente)
Evaluar la consistencia del análisis jeráquico de procesos con 5
dimensiones utilizando 1000 simulaciones. R valor del indice RI se basa
en una distribución aletaoria y se utilizará como referencia para
comparra el índice de consistencia obtenido en la matriz de comparación
de pesos.
## Genere un índice aleatorio con 1000 simulaciones, 5 dimensiones y semilla 30000 para reproducibilidad (semilla = 42 por defecto).
(RI<-ahp.ri(nsims = 1000, dim=5, seed = 30000))## [1] 1.115356## Use este RI para calcular el índice de consistencia en lugar del predeterminado.
ahp.cr(sample_mat, atts, RI)## [1] 0.6290004thres <- 0.1
dict <- c("cult" = "Culture",
"fam" = "Family",
"house" = "Housing",
"jobs" = "Jobs",
"trans" = "Transportation")
cr.df <- city200 %>%
ahp.mat(atts, negconvert = TRUE) %>%
ahp.cr(atts) %>%
data.frame() %>%
mutate(rowid = 1:length(cr), cr.dum = as.factor(ifelse(cr <= thres, 1, 0))) %>%
select(cr.dum, rowid)
city200 %>%
ahp.mat(atts = atts, negconvert = TRUE) %>%
ahp.indpref(atts, method = "eigen") %>%
mutate(rowid = 1:nrow(eigentrue)) %>%
left_join(cr.df, by = 'rowid') %>%
gather(cult, fam, house, jobs, trans, key = "var", value = "pref") %>%
ggplot(aes(x = var, y = pref)) +
geom_violin(alpha = 0.6, width = 0.8, color = "transparent", fill = "gray") +
geom_jitter(alpha = 0.6, height = 0, width = 0.1, aes(color = cr.dum)) +
geom_boxplot(alpha = 0, width = 0.3, color = "#808080") +
scale_x_discrete("Attribute", label = dict) +
scale_y_continuous("Weight (dominant eigenvalue)",
labels = scales::percent,
breaks = c(seq(0,0.7,0.1))) +
guides(color=guide_legend(title=NULL))+
scale_color_discrete(breaks = c(0,1),
labels = c(paste("CR >", thres),
paste("CR <", thres))) +
labs(NULL, caption = paste("n =", nrow(city200), ",", "Mean CR =",
round(mean(cr),3)))+
theme_minimal()