7. Evidencia Empiríca
library(readxl)
Base <- read_excel("C:/Users/MINEDUCYT/Downloads/Base.xlsx")
head(Base, n = 200 )
## # A tibble: 200 × 5
## gasto ingreso remesa ayudagob miembros
## <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 761. 2090. 0 0 4
## 2 166. 180. 0 0 4
## 3 166. 180. 0 0 4
## 4 166. 180. 0 0 4
## 5 166. 180. 0 0 4
## 6 167. 251. 0 600 5
## 7 167. 251. 0 0 5
## 8 167. 251. 0 0 5
## 9 167. 251. 0 0 5
## 10 167. 251. 0 0 5
## # … with 190 more rows
ec_gasto <- lm(formula=gasto ~ingreso+remesa+ayudagob+miembros, data= Base)
library(dplyr)
ec_gasto<-Base %>% round(digits = 2)
names(ec_gasto)<-c("gasto", "ingreso", "remesa", "ayudagob","miembros")
str(ec_gasto)
## tibble [209 × 5] (S3: tbl_df/tbl/data.frame)
## $ gasto : num [1:209] 761 166 166 166 166 ...
## $ ingreso : num [1:209] 2090 180 180 180 180 ...
## $ remesa : num [1:209] 0 0 0 0 0 0 0 0 0 0 ...
## $ ayudagob: num [1:209] 0 0 0 0 0 600 0 0 0 0 ...
## $ miembros: num [1:209] 4 4 4 4 4 5 5 5 5 5 ...
Fuente: Elaboración propia con base a la EHPM, 2019.
10. Simulación
#Proporción de sesgo
Um<-function(pronosticado,observado){
library(DescTools)
((mean(pronosticado)-mean(observado))^2)/MSE(pronosticado,observado)
}
#Proporción de varianza
Us<-function(pronosticado,observado){
library(DescTools)
((sd(pronosticado)-sd(observado))^2)/MSE(pronosticado,observado)
}
#Proporción de Covarianza
Uc<-function(pronosticado,observado){
library(DescTools)
(2*(1-cor(pronosticado,observado))*sd(pronosticado)*sd(observado))/MSE(pronosticado,observado)
}
#Coeficiente U de Theil
library(DescTools)
THEIL_U <-function(pronosticado,observado) {
RMSE(pronosticado,observado)/(sqrt(mean(pronosticado^2))+sqrt(mean(observado^2)))
}
#DataFrame
DataFrame1 <- Base
#Formula del modelo
formula1 <- as.formula(gasto~ingreso+remesa+ayudagob+miembros)
#Semilla
set.seed(50)
#Data de entrenamiento
DEntrenam <- 0.8
#Muestras
numero_de_muestras<-5000
options(scipen = 999999)
library(dplyr)
library(caret)
library(DescTools)
library(stargazer)
muestras<- DataFrame1$gasto %>% createDataPartition(p = DEntrenam,
times = numero_de_muestras,
list = TRUE)
# Listas vacias
Modelos_Entrenamiento<-vector(mode = "list",
length = numero_de_muestras)
Pronostico_Prueba<-vector(mode = "list",
length = numero_de_muestras)
Resultados_Performance_data_entrenamiento<-vector(mode = "list",
length = numero_de_muestras)
Resultados_Performance<-vector(mode = "list",
length = numero_de_muestras)
for(j in 1:numero_de_muestras){
#Data verde
Datos_Entrenamiento<- DataFrame1[muestras[[j]], ]
#Data roja
Datos_Prueba<- DataFrame1[-muestras[[j]], ]
#Cambio de endógena
DatEntrenamiento <- Datos_Entrenamiento$gasto
DatPrueba <- Datos_Prueba$gasto
#Continua el scrip
Modelos_Entrenamiento[[j]]<-lm(formula = formula1 ,data=Datos_Entrenamiento)
Pronostico_Prueba[[j]]<-Modelos_Entrenamiento[[j]] %>% predict(Datos_Prueba)
Resultados_Performance_data_entrenamiento[[j]]<-data.frame(
R2 = R2(Modelos_Entrenamiento[[j]]$fitted.values,
DatEntrenamiento),
RMSE = RMSE(Modelos_Entrenamiento[[j]]$fitted.values,
DatEntrenamiento),
MAE = MAE(Modelos_Entrenamiento[[j]]$fitted.values,
DatEntrenamiento),
MAPE= MAPE(Modelos_Entrenamiento[[j]]$fitted.values,
DatEntrenamiento)*100,
THEIL=TheilU(Modelos_Entrenamiento[[j]]$fitted.values,
DatEntrenamiento,type = 1),
Um=Um(Modelos_Entrenamiento[[j]]$fitted.values,
DatEntrenamiento),
Us=Us(Modelos_Entrenamiento[[j]]$fitted.values,
DatEntrenamiento),
Uc=Uc(Modelos_Entrenamiento[[j]]$fitted.values,
DatEntrenamiento)
)
Resultados_Performance[[j]]<-data.frame(
R2 = R2(Pronostico_Prueba[[j]], DatPrueba),
RMSE = RMSE(Pronostico_Prueba[[j]], DatPrueba),
MAE = MAE(Pronostico_Prueba[[j]], DatPrueba),
MAPE= MAPE(Pronostico_Prueba[[j]], DatPrueba)*100,
THEIL=TheilU(Pronostico_Prueba[[j]], DatPrueba,
type = 1),
Um=Um(Pronostico_Prueba[[j]], DatPrueba),
Us=Us(Pronostico_Prueba[[j]], DatPrueba),
Uc=Uc(Pronostico_Prueba[[j]], DatPrueba)
)
}
10.1 Resultados del modelo
- Medidas de Performance Datos del Modelo
# Data verde
bind_rows(Resultados_Performance_data_entrenamiento) %>%
stargazer(title = "Medidas de Performance Datos del Modelo",
type = "html",
digits = 3)
Medidas de Performance Datos del Modelo
|
|
|
Statistic
|
N
|
Mean
|
St. Dev.
|
Min
|
Max
|
|
|
|
R2
|
5,000
|
0.641
|
0.043
|
0.412
|
0.813
|
|
RMSE
|
5,000
|
196.660
|
9.074
|
145.615
|
212.999
|
|
MAE
|
5,000
|
133.025
|
6.537
|
102.971
|
148.328
|
|
MAPE
|
5,000
|
43.092
|
2.069
|
33.825
|
48.468
|
|
THEIL
|
5,000
|
0.207
|
0.012
|
0.147
|
0.246
|
|
Um
|
5,000
|
0.000
|
0.000
|
0
|
0
|
|
Us
|
5,000
|
0.112
|
0.017
|
0.052
|
0.219
|
|
Uc
|
5,000
|
0.894
|
0.017
|
0.787
|
0.954
|
|
|
- Medidas de Performance Simulación
#Data Roja
bind_rows(Resultados_Performance) %>%
stargazer(title = "Medidas de Performance Simulación",
type = "html",
digits = 3)
Medidas de Performance Simulación
|
|
|
Statistic
|
N
|
Mean
|
St. Dev.
|
Min
|
Max
|
|
|
|
R2
|
5,000
|
0.616
|
0.182
|
0.049
|
0.948
|
|
RMSE
|
5,000
|
199.068
|
37.328
|
110.154
|
365.269
|
|
MAE
|
5,000
|
135.590
|
16.647
|
85.914
|
227.899
|
|
MAPE
|
5,000
|
44.248
|
7.623
|
24.891
|
84.870
|
|
THEIL
|
5,000
|
0.214
|
0.039
|
0.121
|
0.374
|
|
Um
|
5,000
|
0.019
|
0.025
|
0.000
|
0.203
|
|
Us
|
5,000
|
0.187
|
0.167
|
0.000
|
0.744
|
|
Uc
|
5,000
|
0.819
|
0.172
|
0.274
|
1.025
|
|
|
Se concluye que el 61.6% del modelo es explicado por los regresores
(R²), mientras que el error real en estimación del gasto es de un total
de $135.590 (MAE), además, el modelo se equivoca en promedio en un
44.248% (MAPE) de los casos, en donde se espera que el modelo tenga un
error mínimo de 24.891 y uno máximo de 84.870. Por otro lado, la
distancia promedio de las medias de los datos observados y proyectados
del modelo es de 0.019 (Um) y la distancia entre sus medias y
volatilidades es superior al 20% lo cual significa que los pronósticos
que se realizaron al inicio no son tan certeros.