Carga de Datos

# Cargar el archivo .RData
load("C:/Users/User/Desktop/documents_rstudio/ciclo_6/practica_21/data_parcial_2_A_rev.RData")
head(datos_parcial_2)

CLAVE “A”

Desarrolle el siguiente ejercicio: Se necesita construir un indicador multivariado sintético, que mida la “Seguridad Municipal” Para ello se dispone de la siguiente información:

X1 = % de Negocios victimizados durante el año por - robo o hurto

X2 = % de Negocios victimizados durante el año - extorsión o secuestro

X3 = % de Negocios que consideran que el crimen fue mayor en el año actual comparado con el año anterior

X4 = % de Negocios que consideran que el crimen local es mayor que en los municipios vecinos

X5 = Erogaciones municipales per cápita en seguridad pública (US$)

X6 = Costo del crimen a negocios por cada US$1,000 de ventas durante el año previo

X7 = % de Negocios que califican a la municipalidad como buena en prevención y control del delito

X8 = % de Negocios que consideran que la calidad del alumbrado público es adecuada para la seguridad de los negocios en el municipio

Correlación de las variables con la de Seguridad Municipal

X1(+)

X2(+)

X3(+)

X4(-)

X5(+)

X6(-)

X7(+)

X8(+)

1. Cálculo de ponderadores normalizados para cada factor y las variables incluidas en cada factor

A través del análisis de componentes principales, identifique para un modelo de 3 factores: Los ponderadores normalizados para cada factor. Las variables incluidas en cada factor.

Construcción de la matriz de información

library(kableExtra)
mat_XA1<-datos_parcial_2
mat_A1<-mat_XA1[,c(-1,-2)]
mat_A1%>% head() %>% 
  kable(caption ="Matriz de Información:" ,align = "c",digits = 6) %>% 
  kable_material(html_font = "sans-serif")

Matriz de Información:
X1	X2	X3	X4	X5	X6	X7	X8
9	2	20.00000	20.00000	0.00000	0.000000	2	56.4000
10	6	62.50000	50.00000	37.50000	3.947368	11	147.3750
10	20	50.00000	50.00000	50.00000	2.564103	16	135.0000
8	3	42.85714	42.85714	14.28571	1.351351	35	121.1429
7	7	75.00000	75.00000	75.00000	9.090909	8	202.5000
6	13	30.00000	30.00000	30.00000	8.108108	25	81.0000

Normalización de los Datos

library(dplyr)
norm_directa<-function(x){(x-min(x))/(max(x)-min(x))}
norm_inversa<-function(x){(max(x)-x)/(max(x)-min(x))}

df_A1 <- na.omit(mat_A1)
nombres_originales <- names(df_A1)
tipo_correlacion <- c("directa", "directa", "directa", "inversa", "directa", "inversa", "directa", "directa")
names(df_A1) <- paste0(names(df_A1), "_", tipo_correlacion)

df_A1 <- df_A1 %>%
  mutate(across(all_of(ends_with("directa")), norm_directa)) %>%
  mutate(across(all_of(ends_with("inversa")), norm_inversa))

names(df_A1) <- nombres_originales
datos_municipio_normalizados <- df_A1
head(datos_municipio_normalizados)

Matriz de Correlación, Pruebas de Barlett y KMO

library(PerformanceAnalytics)
chart.Correlation(as.matrix(datos_municipio_normalizados),histogram = TRUE,pch=12)

Interpretación En la diagonal principal aparecen los histogramas de las variables analizadas, en el triángulo superior aparecen las correlaciones donde poseen unos asteriscos los cuales nos indican que tan significativas son las correlaciones. Si poseen un astristico significa que poseen un nivel de significancia del 10%, dos asteriscos 95%, y tres asteriscos significa que posee un vivel de significancia del 1%, con esto se rechaza que el coeficiente de correlación a nivel poblacional es igual a cero. Mientras que el el triangular inferior a parece el diagrama de dispersión que indica que tan lineal es la relación de la parejas de variables.

# Instalación de rela
install.packages("C:/Users/User/Desktop/documents_rstudio/ciclo_6/practica_21/rela", repos = NULL, type = "source")

library(rela)
KMO<-paf(as.matrix(mat_A1))$KMO
print(KMO)

## [1] 0.67931

Interpretación Al ser KMO>0.50, significa que los datos si pueden ser utilizados para análisis factorial.

#Prueba de Barlett
options(scipen = 999)
library(psych)
Barlett<-cortest.bartlett(datos_municipio_normalizados)
print(Barlett)

## $chisq
## [1] 1025.9
## 
## $p.value
## [1] 0.0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000046951
## 
## $df
## [1] 28

Interpretación Al ser el p-value < 0.05, se rechaza la hipótesis nula, por lo que si existe evidencia de multicolinealidad.

Análisis Factorial

library(FactoMineR)
library(factoextra)
library(kableExtra)

Rx<-cor(datos_municipio_normalizados)
PC<-princomp(x = datos_municipio_normalizados,cor = TRUE,fix_sign = FALSE)
variables_pca<-get_pca_var(PC)
factoextra::get_eig(PC) %>% kable(caption="Resumen de PCA",
        align = "c",
        digits = 2) %>% 
  kable_material(html_font = "sans-serif") %>% 
  kable_styling(bootstrap_options = c("hover"))

Resumen de PCA
	eigenvalue	variance.percent	cumulative.variance.percent
Dim.1	3.90	48.72	48.72
Dim.2	1.96	24.55	73.27
Dim.3	0.84	10.52	83.78
Dim.4	0.50	6.24	90.03
Dim.5	0.45	5.68	95.70
Dim.6	0.28	3.45	99.16
Dim.7	0.07	0.82	99.98
Dim.8	0.00	0.02	100.00

Según el criterio de raíz latente, obtendríamos 2 componentes. Pero con el criterio del porcentaje acumulado de la varianza, serían 3 componentes, porque estas tres explican más de tres cuartas partes de la varianza total.

Gráfico de Sedimentación

Un gráfico de sedimentación representa los eigenvalores (valores propios) en función del número de componentes. Los eigenvalores indican la cantidad de varianza explicada por cada componente.

fviz_eig(PC,
         choice = "eigenvalue",
         barcolor = "green",
         barfill = "green",
         addlabels = TRUE, 
       )+labs(title = "Grafico de Sedimentacion",subtitle = "Usando princomp, con Autovalores")+
  xlab(label = "Componentes")+
  ylab(label = "Autovalores")+geom_hline(yintercept = 1)

Interpretación La regla común es retener los componentes que están antes del codo, por lo que se retienen los dos primeros componentes,ya que son los que explican una cantidad significativa de varianza.

library(corrplot)
#Modelo de 3 Factores (Rotada)
numero_de_factores<-3
modelo_factores<-principal(r = Rx,
                             nfactors = numero_de_factores,
                             covar = FALSE,
                             rotate = "varimax")
modelo_factores

## Principal Components Analysis
## Call: principal(r = Rx, nfactors = numero_de_factores, rotate = "varimax", 
##     covar = FALSE)
## Standardized loadings (pattern matrix) based upon correlation matrix
##      RC1   RC2   RC3   h2     u2 com
## X1 -0.16  0.80 -0.03 0.67 0.3316 1.1
## X2  0.08  0.84 -0.03 0.71 0.2879 1.0
## X3  0.93 -0.09  0.28 0.95 0.0493 1.2
## X4 -0.95  0.05 -0.26 0.98 0.0208 1.2
## X5  0.43 -0.06  0.80 0.83 0.1742 1.5
## X6 -0.25  0.03 -0.91 0.89 0.1142 1.2
## X7 -0.07  0.83 -0.04 0.69 0.3107 1.0
## X8  0.96 -0.06  0.27 0.99 0.0087 1.2
## 
##                        RC1  RC2  RC3
## SS loadings           2.97 2.05 1.68
## Proportion Var        0.37 0.26 0.21
## Cumulative Var        0.37 0.63 0.84
## Proportion Explained  0.44 0.31 0.25
## Cumulative Proportion 0.44 0.75 1.00
## 
## Mean item complexity =  1.2
## Test of the hypothesis that 3 components are sufficient.
## 
## The root mean square of the residuals (RMSR) is  0.06 
## 
## Fit based upon off diagonal values = 0.98

Interpretación

El porcentaje global de la varianza explicada para esta solución si la bateria de indicadores pasara a ser representada por tres componentes, el 16% caería en el componente 1, el 80% en el componente 2 y el 3% en el componente 3. Asimismo el 66% de la varianza de X1 esta representado por esta solución y solo el 33% se corresponde a características propias de ese indicador.

En cuanto a los ponderadores obtenidos, la primera variable que se construya tendrá un ponderador de 0.44, la segunda de 0.31 y la tercera de 0.25.

2. Las variables incluidas en cada factor.

correlaciones_modelo<-variables_pca$coord
rotacion<-varimax(correlaciones_modelo[,1:numero_de_factores])
correlaciones_modelo_rotada<-rotacion$loadings

corrplot(correlaciones_modelo_rotada[,1:numero_de_factores],
         is.corr = FALSE,
         method = "square",
         addCoef.col="grey",
         number.cex = 0.75)

Interpretación AL observar el gráfico el factor 1 está representado por las variables X3, X4 y X8. El factor 2 está más asociado con las variables X1, X2 y X7. El factor 3 está más relacionado con las variables X5 y X6.

library(kableExtra)
cargas<-rotacion$loadings[1:6,1:numero_de_factores]
ponderadores<-prop.table(apply(cargas^2,MARGIN = 2,sum))
t(ponderadores) %>% kable(caption="Ponderadores de los Factores Extraídos",
        align = "c",
        digits = 3) %>% 
  kable_material(html_font = "sans-serif") %>% 
  kable_styling(bootstrap_options = c("striped", "hover"))

Ponderadores de los Factores Extraídos
Dim.1	Dim.2	Dim.3
0.409	0.271	0.32

contribuciones<-apply(cargas^2,MARGIN = 2,prop.table)
contribuciones %>% kable(caption="Contribución de las variables en los Factores",
        align = "c",
        digits = 3) %>% 
  kable_material(html_font = "sans-serif") %>% 
  kable_styling(bootstrap_options = c("striped", "hover"))

Contribución de las variables en los Factores
	Dim.1	Dim.2	Dim.3
X1	0.013	0.471	0.001
X2	0.003	0.519	0.000
X3	0.422	0.006	0.048
X4	0.443	0.002	0.042
X5	0.089	0.002	0.398
X6	0.031	0.001	0.511

3. Para el factor 1, utilice el método CRITIC para obtener los ponderadores normalizados para cada variable.

Función Personalizada sobre el Método CRITIC

### Método CRITIC
ponderadores_critic <- function(matriz_datos) {
  sigma <- apply(X = matriz_datos, MARGIN = 2, sd)
  rho <- cor(matriz_datos)
  cj <- apply(X = 1 - rho, MARGIN = 2, sum)
  pesos_brutos <- sigma * cj
  pesos_normalizados <- prop.table(pesos_brutos)
  resultados <- list(pesos_brutos = pesos_brutos,
                     pesos_normalizados = pesos_normalizados)
  return(resultados) 
}

Aplicación del Meétodo Critic

ejercicio_factorA1<- datos_municipio_normalizados[, c("X3","X4","X8")]
solucion_critic<- ponderadores_critic(matriz_datos = ejercicio_factorA1) %>%
  print()

## $pesos_brutos
##      X3      X4      X8 
## 0.48755 0.79129 0.42517 
## 
## $pesos_normalizados
##      X3      X4      X8 
## 0.28612 0.46437 0.24951

4. Para el factor 2, utilice el método de Entropía para obtener los ponderadores normalizados para cada variable.

Función personalizada sobre el Método de Entriopía

### Método de Entropía
ponderadores_entropia <- function(matriz_datos, constante = 0){
  aij <- apply(X = matriz_datos + constante, MARGIN = 2, prop.table)
  log_aij <- apply(X = aij, MARGIN = 2, log10)
  aij_log_aij <- aij * log_aij
  sum_aij_log_aij <- apply(X = aij_log_aij, MARGIN = 2, sum)
  n <- nrow(matriz_datos)
  K <- 1 / log10(n)
  E <- (-K * sum_aij_log_aij)
  pesos_brutos <- 1 - E
  pesos_normalizados <- prop.table(pesos_brutos)
  resultados <- list(pesos_brutos = pesos_brutos,
                     pesos_normalizados = pesos_normalizados)
  return(resultados)
}

Aplicación del Método de Entriopía

ejercicio_factorA2<- datos_municipio_normalizados[, c("X1","X2","X7")]
resultados_entropia <- ponderadores_entropia(matriz_datos = ejercicio_factorA2, constante = 10) %>%
  print()

## $pesos_brutos
##          X1          X2          X7 
## 0.000026975 0.000057336 0.000044061 
## 
## $pesos_normalizados
##      X1      X2      X7 
## 0.21013 0.44664 0.34323

5. Para el factor 3, utilice el método de Ranking para obtener los ponderadores normalizados para cada variable (utilice la numeración de las variables para establecer la jerarquía).

Metodo Ranking Suma

library(magrittr)
#Vector de Jerarquías
rj<-c(1,2)
names(rj)<-c("X5","X6")

#Función para generar los pesos
ponderadores_subjetivos_rank_suma<-function(vector_jerarquias){
  n<-length(vector_jerarquias)
  vector_pesos<-n-vector_jerarquias+1
  list(w_brutos=vector_pesos,w_normalizados=vector_pesos/sum(vector_pesos))
}
#Aplicando la función:
pesos_ranking_suma<-ponderadores_subjetivos_rank_suma(rj)

#Pesos brutos
pesos_ranking_suma$w_brutos

## X5 X6 
##  2  1

Pesos normalizados por el ranking suma

pesos_ranking_suma$w_normalizados %>% round(digits = 3)

##    X5    X6 
## 0.667 0.333

Gráfica sobre los pesos normalizados por el ranking suma

barplot(pesos_ranking_suma$w_normalizados,
        main = "Ponderadores Ranking de Suma",
        ylim = c(0,0.7),col = "purple")

### Método Ranking Reciproca

#Vector de Jerarquías
rj<-c(1,2)
names(rj)<-c("X5","X6")

#Función para generar los pesos
ponderadores_subjetivos_rank_reciproco<-function(vector_jerarquias){
  vector_pesos<-1/vector_jerarquias
  list(w_brutos=vector_pesos,w_normalizados=vector_pesos/sum(vector_pesos))
}
#Aplicando la función:
pesos_ranking_reciproco<-ponderadores_subjetivos_rank_reciproco(rj)

#Pesos brutos
pesos_ranking_reciproco$w_brutos

##  X5  X6 
## 1.0 0.5

#Pesos normalizados por el ranking reciproco

pesos_ranking_reciproco$w_normalizados %>% round(digits = 3)

##    X5    X6 
## 0.667 0.333

Gráfica sobre los pesos normalizados por el ranking reciproco

barplot(pesos_ranking_reciproco$w_normalizados,
        main = "Ponderadores Ranking Recíproco",
        ylim = c(0,0.7),col = "brown")

Función Personalizada sobre Metodo de Ranking Exponencial

#Vector de Jerarquías
rj<-c(1,2)
names(rj)<-c("X5","X6")

#Función para generar los pesos
ponderadores_subjetivos_rank_exponencial<-function(vector_jerarquias,p=2){
  n<-length(vector_jerarquias)
  vector_pesos<-(n-vector_jerarquias+1)^p
  list(w_brutos=vector_pesos,w_normalizados=vector_pesos/sum(vector_pesos))
}
#Aplicando la función:
pesos_ranking_exponencial<-ponderadores_subjetivos_rank_exponencial(rj)

#Pesos brutos
pesos_ranking_exponencial$w_brutos

## X5 X6 
##  4  1

Pesos normalizados por el ranking exponencial

pesos_ranking_exponencial$w_normalizados %>% round(digits = 2)

##  X5  X6 
## 0.8 0.2

Gráfico sobre los pesos normalizados por el ranking exponencial

barplot(pesos_ranking_suma$w_normalizados,
        main = "Ponderadores Ranking Exponencial",
        ylim = c(0,0.9),col = "lightblue")

#Comparación de valores de "p"

par(mfrow=c(1,3))
for(p in 2:4){
  
  pesos<-ponderadores_subjetivos_rank_exponencial(vector_jerarquias = rj,p = p)
  barplot(pesos$w_normalizados,main = paste0("p=",p),ylim = c(0,0.7),col = "pink",cex.main=3,cex.axis = 3)
}

CLAVE “B”

Sección 1

Carga de datos

library(readr)

## Warning: package 'readr' was built under R version 4.4.1

library(tidyr)

## Warning: package 'tidyr' was built under R version 4.4.1

## 
## Adjuntando el paquete: 'tidyr'

## The following object is masked from 'package:magrittr':
## 
##     extract

library(dplyr)
library(kableExtra)

load("C:/Users/User/Desktop/documents_rstudio/ciclo_6/practica_21/data_parcial_2_B_rev.RData")
datos_desarrollo_economic <- data_parcial_2 %>% 
  select(ALFABET, INC_POB, ESPVIDAF, MORTINF, FERTILID, TASA_NAT, LOG_PIB, URBANA, TASA_MOR)

head(datos_desarrollo_economic)

Descripción de Datos

Se tiene como objetivo construir un indicador multivariado sintético sobre el “Desarrollo en las Economías”, para lo cual se tiene la siguiente información con sus respectivas correlaciones teóricas esperadas entre la variable compleja y el indicador.

Los indicadores a considerar son*:

El índice de alfabetización (alfabet)[+]

El incremento de la población (inc_pob)[+]

La esperanza de vida femenina (espvidaf)[+]

La mortalidad infantil (mortinf)[-]

El número promedio de hijos por mujer (fertilid)[+]

La tasa de natalidad (tasa_nat)[+]

El logaritmo del PIB (log_pib)[+]

La población urbana (urbana)[+]

La tasa de mortalidad (tasa_mor)[-]

Normalización de los Datos

library(dplyr)
norm_directa<-function(x){(x-min(x))/(max(x)-min(x))}
norm_inversa<-function(x){(max(x)-x)/(max(x)-min(x))}

df <- na.omit(datos_desarrollo_economic)
nombres_originales <- names(df)
tipo_correlacion <- c("directa", "directa", "directa", "inversa", "directa", "directa", "directa", "directa", "inversa")
names(df) <- paste0(names(df), "_", tipo_correlacion)

df <- df %>%
  mutate(across(all_of(ends_with("directa")), norm_directa)) %>%
  mutate(across(all_of(ends_with("inversa")), norm_inversa))

names(df) <- nombres_originales
datos_economics_normalizados <- df
head(datos_economics_normalizados)

Matriz de Correlación, Pruebas de Barlett y KMO

#Matriz de correlación
library(PerformanceAnalytics)
chart.Correlation(as.matrix(datos_economics_normalizados),histogram = TRUE,pch=12)

Interpretación

El gráfico observado indica que todas las variables tienen un alto nivel de significancia rachazando que el coeficiente de corrrelación a nivel poblacional es igual a cero.

Usando Rela

#KMO
library(rela)
KMO2<-paf(as.matrix(datos_economics_normalizados))$KMO
print(KMO2)

## [1] 0.86467

Interpretación Al ser KMO>0.50, significa que los datos si pueden ser utilizados para análisis factorial.

#Prueba de Barlett
library(psych)
options(scipen = 99999)
Barlett<-cortest.bartlett(datos_economics_normalizados)
print(Barlett)

## $chisq
## [1] 1544.4
## 
## $p.value
## [1] 0.00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000015692
## 
## $df
## [1] 36

Interpretación El P value es casi 0, por lo que indica que se rechaza la hipótesis nula. Esto significa que existe evidencia de correlación poblacional entre el conjunto de indicadores.

Análisis Factorial

1. Usando análisis factorial determine cuántos factores deberían retenerse.

library(FactoMineR)
library(factoextra)
library(kableExtra)

Rx<-cor(datos_economics_normalizados)
PC<-princomp(x = datos_economics_normalizados,cor = TRUE,fix_sign = FALSE)
variables_pca<-get_pca_var(PC)
factoextra::get_eig(PC) %>% kable(caption="Resumen de PCA",
        align = "c",
        digits = 2) %>% 
  kable_material(html_font = "sans-serif") %>% 
  kable_styling(bootstrap_options = c("hover"))

Resumen de PCA
	eigenvalue	variance.percent	cumulative.variance.percent
Dim.1	6.69	74.34	74.34
Dim.2	1.24	13.83	88.18
Dim.3	0.53	5.91	94.08
Dim.4	0.20	2.20	96.28
Dim.5	0.17	1.93	98.21
Dim.6	0.07	0.73	98.94
Dim.7	0.06	0.62	99.56
Dim.8	0.03	0.28	99.84
Dim.9	0.01	0.16	100.00

Existen dos criterios que permiten determinar la cantidad de factores a retener; según el criterio de raíz latente, se podriían retener 2 componentes, asimismo por el criterio de porcentaje acumulado de la varianza, también se obtendrían 2 componentes, ya que explican más de tres cuartas partes de la varianza total.

Gráfico de Sedimentación

fviz_eig(PC,
         choice = "eigenvalue",
         barcolor = "orange",
         barfill = "orange",
         addlabels = TRUE, 
       )+labs(title = "Gráfico de Sedimentación",subtitle = "Usando princomp, con Autovalores")+
  xlab(label = "Componentes")+
  ylab(label = "Autovalores")+geom_hline(yintercept = 1)

El punto de quiebre se muestra en los primeros dos componentes, por lo que el criterio de extracción indica la retención de 2 factores.

2. ¿Qué variables quedan representadas en cada factor?

library(corrplot)
#Modelo de 2 Factores (Rotada)
numero_de_factores<-2
modelo_factores<-principal(r = Rx,
                             nfactors = numero_de_factores,
                             covar = FALSE,
                             rotate = "varimax")
print(modelo_factores)

## Principal Components Analysis
## Call: principal(r = Rx, nfactors = numero_de_factores, rotate = "varimax", 
##     covar = FALSE)
## Standardized loadings (pattern matrix) based upon correlation matrix
##            RC1   RC2   h2    u2 com
## ALFABET   0.76  0.53 0.86 0.141 1.8
## INC_POB  -0.98  0.05 0.96 0.042 1.0
## ESPVIDAF  0.62  0.76 0.96 0.036 1.9
## MORTINF   0.66  0.71 0.94 0.059 2.0
## FERTILID -0.87 -0.40 0.92 0.079 1.4
## TASA_NAT -0.90 -0.40 0.97 0.034 1.4
## LOG_PIB   0.65  0.58 0.75 0.246 2.0
## URBANA    0.42  0.73 0.71 0.294 1.6
## TASA_MOR -0.02  0.93 0.87 0.135 1.0
## 
##                        RC1  RC2
## SS loadings           4.52 3.41
## Proportion Var        0.50 0.38
## Cumulative Var        0.50 0.88
## Proportion Explained  0.57 0.43
## Cumulative Proportion 0.57 1.00
## 
## Mean item complexity =  1.6
## Test of the hypothesis that 2 components are sufficient.
## 
## The root mean square of the residuals (RMSR) is  0.05 
## 
## Fit based upon off diagonal values = 1

Interpretación

El porcentaje global de la varianza explicada para esta solución si la bateria de indicadores pasara a ser representada por dos componentes, el 76% caería en el componente 1 y el 53% en el componente 2 . Asimismo el 86% de la varianza de X1 esta representado por esta solución y solo el 14% se corresponde a características propias de ese indicador.

En cuanto a los ponderadores obtenidos, la primera variable que se construya tendrá un ponderador de 0.57, y la segunda de 0.43.

#Gráfico de aglomeración de las variables en los factores
correlaciones_modelo<-variables_pca$coord
rotacion<-varimax(correlaciones_modelo[,1:numero_de_factores])
correlaciones_modelo_rotada<-rotacion$loadings

corrplot(correlaciones_modelo_rotada[,1:numero_de_factores],
         is.corr = FALSE,
         method = "square",
         addCoef.col="black",
         number.cex = 0.75)

Según el gráfico de aglomeración de las variables en los factores, el factor 1 quedan representado por las variables ALFABET, INC_POB, FERTILID, TASA_NAT y LOG_PIB y en el factor 2 quedan representadas las variables ESPVIDAF, URBANA, MORTINF y TASA_MOR.

3. Determine qué pesos deben asignarse a cada factor y a las variables dentro de cada uno de ellos.

# Cargas de cada dimensión
library(kableExtra)
cargas<-rotacion$loadings[1:9,1:numero_de_factores]
ponderadores<-prop.table(apply(cargas^2,MARGIN = 2,sum))
t(ponderadores) %>% kable(caption="Ponderadores de los Factores Extraídos",
        align = "c",
        digits = 3) %>% 
  kable_material(html_font = "sans-serif") %>% 
  kable_styling(bootstrap_options = c("striped", "hover"))

Ponderadores de los Factores Extraídos
Dim.1	Dim.2
0.57	0.43

Interpretación

La dimensión 1 explica el 57% de la varianza total de los datos, mientras que la dimensión 2 explica aproximadamente el 43% de la varianza total de los datos.

# Contribuciones
contribuciones<-apply(cargas^2,MARGIN = 2,prop.table)
contribuciones %>% kable(caption="Contribución de las variables en los Factores",
        align = "c",
        digits = 3) %>% 
  kable_material(html_font = "sans-serif") %>% 
  kable_styling(bootstrap_options = c("striped", "hover"))

Contribución de las variables en los Factores
	Dim.1	Dim.2
ALFABET	0.128	0.083
INC_POB	0.211	0.001
ESPVIDAF	0.086	0.168
MORTINF	0.097	0.147
FERTILID	0.168	0.048
TASA_NAT	0.178	0.047
LOG_PIB	0.093	0.098
URBANA	0.039	0.155
TASA_MOR	0.000	0.253

Interpretación Muestra la contibución que tiene cada variable en cada factor, por ejemplo ALFABET en la dimensión 1 muestra el 13% de peso, pero es aún menor en la dimensión 2 con el 8%.

Sección 2

Descripción de Datos

Una empresa se encuentra calculando un Indicador del desempeño de sus líneas de producción, para ello no dispone de información previa, pero hay una importante consultora que posee expertos en el sector donde se ubica la empresa en cuestión.

La consultora, ha han determinado 4 variables que definen adecuadamente el desempeño de las líneas de producción:

X1: Mantenimiento de la línea de producción

X2: Tamaño de planta

X3: Logística (entradas y salidas de insumos y producción)

X4: Capacidad de innovación.

Ejercicio 1. Cálculo de los pesos normalizados, de las variables, usando los métodos de ranking directo, por suma, por reciproco y por ranking exponencial (usando p=4)

1. Método Ranking Suma

library(magrittr)
#Vecto de Jerarquias
rj <- c(3,4,2,1)
names(rj) <- c("X1", "X2", "X3", "X4")
#Funcion para generar los pesos
ponderadores_subjetivos_rank_suma <- function(vector_jerarquias) {
  n <- length(vector_jerarquias)
  vector_pesos <- n - vector_jerarquias + 1
  list(w_brutos = vector_pesos,
       w_normalizados = vector_pesos / sum(vector_pesos))
}
#Aplicando la funcion
pesos_ranking_suma <- ponderadores_subjetivos_rank_suma(rj)

#Pesos brutos
pesos_ranking_suma$w_brutos

## X1 X2 X3 X4 
##  2  1  3  4

Pesos normalizados “Metodo Ranking Suma”

pesos_ranking_suma$w_normalizados %>% round(digits = 2)

##  X1  X2  X3  X4 
## 0.2 0.1 0.3 0.4

Gráfico de pesos normalizados por ranking suma

barplot(pesos_ranking_suma$w_normalizados,
  main = "Ponderadores Jerarquia de Suma",
  ylim = c(0, 0.5),
  col = "cyan"
)

2. Método Ranking Recíproca

#Vector de Jerarquias
rj <- c(3, 4, 2, 1)
names(rj) <- c("X1", "X2", "X3", "X4")
#Funcion para generar los pesos
ponderadores_subjetivos_rank_reciproco <- function(vector_jerarquias) {
  vector_pesos <- 1 / vector_jerarquias
  list(w_brutos = vector_pesos,
       w_normalizados = vector_pesos / sum(vector_pesos))
}
#Aplicando la funcion
pesos_ranking_reciproco <- ponderadores_subjetivos_rank_reciproco(rj)
#Pesos brutos
pesos_ranking_reciproco$w_brutos

##      X1      X2      X3      X4 
## 0.33333 0.25000 0.50000 1.00000

Pesos normalizados “Método Ranking Recíproca”

pesos_ranking_reciproco$w_normalizados %>% round(digits = 3)

##   X1   X2   X3   X4 
## 0.16 0.12 0.24 0.48

Gráfico de pesos normalizados por jerarquía recíproca

barplot(pesos_ranking_reciproco$w_normalizados,
  main = "Ponderadores Ranking Recíproco",
  ylim = c(0, 0.5),
  col = "magenta"
)

3. Método de Ranking Exponencial

#Vector de Jerarquias
rj <- c(3, 4, 2, 1)
names(rj) <- c("X1", "X2", "X3", "X4")

#Funcion para generar los pesos
ponderadores_subjetivos_rank_exponencial <-
  function(vector_jerarquias, p = 4) {
    n <- length(vector_jerarquias)
    vector_pesos <- (n - vector_jerarquias + 1)^p
    list(w_brutos = vector_pesos,
         w_normalizados = vector_pesos / sum(vector_pesos))
  }
#Aplicando la funcion
pesos_ranking_exponencial <-
  ponderadores_subjetivos_rank_exponencial(rj)
#Pesos brutos
pesos_ranking_exponencial$w_brutos

##  X1  X2  X3  X4 
##  16   1  81 256

Pesos normalizados “Método de Ranking Exponencial”

pesos_ranking_exponencial$w_normalizados %>% round(digits = 2)

##   X1   X2   X3   X4 
## 0.05 0.00 0.23 0.72

Gráfico de pesos normalizados por el método de ranking exponencial

barplot(pesos_ranking_exponencial$w_normalizados,
        main = "Ponderadores Ranking Exponencial",
        ylim = c(0,0.8),col = "turquoise")

Ejercicio 2. Usando la técnica de comparación por pares, calcule los pesos normalizados para las variables:

Texto alternativo

Investigador 1

library(FuzzyAHP)

valores_matriz_comparacion_1 = c(1,7,4,5,
                                 NA,1,6,3,
                                 NA,NA,1,2,
                                 NA,NA,NA,1)
comparacion_1<-matrix(valores_matriz_comparacion_1,
                           nrow = 4, ncol = 4, byrow = TRUE)
comparacion_1<-pairwiseComparisonMatrix(comparacion_1)
comparacion_1@variableNames<-c("X1","X2","X3","X4")
show(comparacion_1)

## An object of class "PairwiseComparisonMatrix"
## Slot "valuesChar":
##      [,1]  [,2]  [,3]  [,4]
## [1,] "1"   "7"   "4"   "5" 
## [2,] "1/7" "1"   "6"   "3" 
## [3,] "1/4" "1/6" "1"   "2" 
## [4,] "1/5" "1/3" "1/2" "1" 
## 
## Slot "values":
##         [,1]    [,2] [,3] [,4]
## [1,] 1.00000 7.00000  4.0    5
## [2,] 0.14286 1.00000  6.0    3
## [3,] 0.25000 0.16667  1.0    2
## [4,] 0.20000 0.33333  0.5    1
## 
## Slot "variableNames":
## [1] "X1" "X2" "X3" "X4"

#Cálculo de los pesos:
normalizados_pesos__b1 = calculateWeights(comparacion_1)
show(normalizados_pesos__b1)

## An object of class "Weights"
## Slot "weights":
##     w_X1     w_X2     w_X3     w_X4 
## 0.606592 0.223310 0.094748 0.075350

barplot(normalizados_pesos__b1@weights,
        main = "Ponderadores por metodo comparacion de pares",
        ylim = c(0,0.7),col = "plum")

Investigador 2

valores_matriz_comparacion_2 = c(1,7,6,3,
                                 NA,1,5,2,
                                 NA,NA,1,4,
                                 NA,NA,NA,1)
comparacion_b2<-matrix(valores_matriz_comparacion_2,
                           nrow = 4, ncol = 4, byrow = TRUE)
comparacion_b2<-pairwiseComparisonMatrix(comparacion_b2)
comparacion_b2@variableNames<-c("X1","X2","X3","X4")
show(comparacion_b2)

## An object of class "PairwiseComparisonMatrix"
## Slot "valuesChar":
##      [,1]  [,2]  [,3]  [,4]
## [1,] "1"   "7"   "6"   "3" 
## [2,] "1/7" "1"   "5"   "2" 
## [3,] "1/6" "1/5" "1"   "4" 
## [4,] "1/3" "1/2" "1/4" "1" 
## 
## Slot "values":
##         [,1] [,2] [,3] [,4]
## [1,] 1.00000  7.0 6.00    3
## [2,] 0.14286  1.0 5.00    2
## [3,] 0.16667  0.2 1.00    4
## [4,] 0.33333  0.5 0.25    1
## 
## Slot "variableNames":
## [1] "X1" "X2" "X3" "X4"

#Cálculo de los pesos:
normalizados_pesos_b2 = calculateWeights(comparacion_b2)
show(normalizados_pesos_b2)

## An object of class "Weights"
## Slot "weights":
##    w_X1    w_X2    w_X3    w_X4 
## 0.60919 0.19879 0.10987 0.08215

barplot(normalizados_pesos_b2@weights,
        main = "Ponderadores por Método Comparación de Pares",
        ylim = c(0,0.7),col = "blue")

Investigador 3

valores_matriz_comparacion_3 = c(1,7,5,4,
                                 NA,1,3,2,
                                 NA,NA,1,6,
                                 NA,NA,NA,1)
comparacion_b3<-matrix(valores_matriz_comparacion_3,
                           nrow = 4, ncol = 4, byrow = TRUE)
comparacion_b3<-pairwiseComparisonMatrix(comparacion_b3)
comparacion_b3@variableNames<-c("X1","X2","X3","X4")
show(comparacion_b3)

## An object of class "PairwiseComparisonMatrix"
## Slot "valuesChar":
##      [,1]  [,2]  [,3]  [,4]
## [1,] "1"   "7"   "5"   "4" 
## [2,] "1/7" "1"   "3"   "2" 
## [3,] "1/5" "1/3" "1"   "6" 
## [4,] "1/4" "1/2" "1/6" "1" 
## 
## Slot "values":
##         [,1]    [,2]    [,3] [,4]
## [1,] 1.00000 7.00000 5.00000    4
## [2,] 0.14286 1.00000 3.00000    2
## [3,] 0.20000 0.33333 1.00000    6
## [4,] 0.25000 0.50000 0.16667    1
## 
## Slot "variableNames":
## [1] "X1" "X2" "X3" "X4"

#Cálculo de los pesos:
normalizados_pesos_b3 = calculateWeights(comparacion_b3)
show(normalizados_pesos_b3 )

## An object of class "Weights"
## Slot "weights":
##    w_X1    w_X2    w_X3    w_X4 
## 0.61676 0.17252 0.14259 0.06812

barplot(normalizados_pesos_b3@weights,
        main = "Ponderadores por Metodo Comparacion de Pares",
        ylim = c(0,0.7),col = "yellow")

2.1 Asumiendo que la opinión de los 3 expertos es igualmente válida.

library(kableExtra)
ponderacion_expertos <-1/3

pesos_tot<-(normalizados_pesos__b1@weights+
            normalizados_pesos_b2@weights+
            normalizados_pesos_b3@weights)

promedio_total<-ponderacion_expertos*pesos_tot
show(promedio_total)

##     w_X1     w_X2     w_X3     w_X4 
## 0.610848 0.198207 0.115739 0.075207

normalizados_pesos_b2

## An object of class "Weights"
## Slot "weights":
##    w_X1    w_X2    w_X3    w_X4 
## 0.60919 0.19879 0.10987 0.08215

#ponderacion de expertos normalizadas
normalizacion_1<-promedio_total/sum(promedio_total)
show(normalizacion_1)

##     w_X1     w_X2     w_X3     w_X4 
## 0.610848 0.198207 0.115739 0.075207

2.2 Si el experto 1 se pondera con 0.25, el experto 2 con 0.35 y el experto 3 con 0.4

ponderacion_expertos_distintas <- (normalizados_pesos__b1@weights * 0.25 + normalizados_pesos_b2@weights * 0.35 + normalizados_pesos_b3@weights * 0.4)

show(ponderacion_expertos_distintas)

##     w_X1     w_X2     w_X3     w_X4 
## 0.611569 0.194412 0.119180 0.074838

sum(ponderacion_expertos_distintas)

## [1] 1

#ponderaciones de expertos distintas normalizadas
normalizacion_total<-ponderacion_expertos_distintas/sum(ponderacion_expertos_distintas)
show(normalizacion_total)

##     w_X1     w_X2     w_X3     w_X4 
## 0.611569 0.194412 0.119180 0.074838

A21-Práctica de Cálculo de Ponderadores

VERONICA NAYELI MIRANDA MEJIA MM21065

2024-11-11

Carga de Datos

CLAVE “A”

1. Cálculo de ponderadores normalizados para cada factor y las variables incluidas en cada factor

Construcción de la matriz de información

Normalización de los Datos

Matriz de Correlación, Pruebas de Barlett y KMO

Análisis Factorial

Gráfico de Sedimentación

2. Las variables incluidas en cada factor.

3. Para el factor 1, utilice el método CRITIC para obtener los ponderadores normalizados para cada variable.

Función Personalizada sobre el Método CRITIC

Aplicación del Meétodo Critic

4. Para el factor 2, utilice el método de Entropía para obtener los ponderadores normalizados para cada variable.

Función personalizada sobre el Método de Entriopía

Aplicación del Método de Entriopía

5. Para el factor 3, utilice el método de Ranking para obtener los ponderadores normalizados para cada variable (utilice la numeración de las variables para establecer la jerarquía).

Metodo Ranking Suma

Pesos normalizados por el ranking suma

Gráfica sobre los pesos normalizados por el ranking suma

Gráfica sobre los pesos normalizados por el ranking reciproco

Función Personalizada sobre Metodo de Ranking Exponencial

Pesos normalizados por el ranking exponencial

Gráfico sobre los pesos normalizados por el ranking exponencial

CLAVE “B”

Sección 1

Carga de datos

Descripción de Datos

Normalización de los Datos

Matriz de Correlación, Pruebas de Barlett y KMO

Usando Rela

Análisis Factorial

1. Usando análisis factorial determine cuántos factores deberían retenerse.

Gráfico de Sedimentación

2. ¿Qué variables quedan representadas en cada factor?

3. Determine qué pesos deben asignarse a cada factor y a las variables dentro de cada uno de ellos.

Sección 2

Descripción de Datos

Ejercicio 1. Cálculo de los pesos normalizados, de las variables, usando los métodos de ranking directo, por suma, por reciproco y por ranking exponencial (usando p=4)

1. Método Ranking Suma

Pesos normalizados “Metodo Ranking Suma”

Gráfico de pesos normalizados por ranking suma

2. Método Ranking Recíproca

Pesos normalizados “Método Ranking Recíproca”

Gráfico de pesos normalizados por jerarquía recíproca

3. Método de Ranking Exponencial

Pesos normalizados “Método de Ranking Exponencial”

Gráfico de pesos normalizados por el método de ranking exponencial

Ejercicio 2. Usando la técnica de comparación por pares, calcule los pesos normalizados para las variables:

Investigador 1

Investigador 2

Investigador 3

2.1 Asumiendo que la opinión de los 3 expertos es igualmente válida.

2.2 Si el experto 1 se pondera con 0.25, el experto 2 con 0.35 y el experto 3 con 0.4