Estimación
library(forecast)
library(kableExtra)
X_n<-data.frame(cigpric=60.506,lcigpric=4.102743,income=20000,lincome=9.903487,age=46,agesq=2116,educ=16.0,white=1,restaurn=0)
confidense<-c(0.95,0.99)
pronosticos<-forecast(object = Modelo_smoke,
level=confidense,
newdata = X_n,
ts=FALSE)
kable(pronosticos,
caption = "Pronósticos e intervalos de confianza",
digits = 2,format = "html")
Pronósticos e intervalos de confianza
|
Point Forecast
|
Lo 95
|
Hi 95
|
Lo 99
|
Hi 99
|
|
9.99
|
-16.41
|
36.39
|
-24.74
|
44.72
|
Um<-function(pronosticado,observado){
library(DescTools)
((mean(pronosticado)-mean(observado))^2)/MSE(pronosticado,observado)
}
Us<-function(pronosticado,observado){
library(DescTools)
((sd(pronosticado)-sd(observado))^2)/MSE(pronosticado,observado)
}
Uc<-function(pronosticado,observado){
library(DescTools)
(2*(1-cor(pronosticado,observado))*sd(pronosticado)*sd(observado))/MSE(pronosticado,observado)}
THEIL_U<-function(pronosticado,observado){
library(DescTools)
RMSE(pronosticado,observado)/(sqrt(mean(pronosticado^2))+sqrt(mean(observado^2)))
}
options(scipen = 999999)
library(dplyr)
library(caret)
library(DescTools)
library(stargazer)
set.seed(50)
numero_de_muestras<-500
muestras<- data$cigs %>%
createDataPartition(p = 0.75,
times = numero_de_muestras,
list = TRUE)
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){
Datos_Entrenamiento<- data[muestras[[j]], ]
Datos_Prueba<- data[-muestras[[j]], ]
Modelos_Entrenamiento[[j]]<-lm(formula = cigs~cigpric+lcigpric+income+lincome+age+agesq+educ+white+restaurn,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,
Datos_Entrenamiento$cigs),
RMSE = RMSE(Modelos_Entrenamiento[[j]]$fitted.values,
Datos_Entrenamiento$cigs),
MAE = MAE(Modelos_Entrenamiento[[j]]$fitted.values,
Datos_Entrenamiento$cigs),
MAPE= MAPE(Modelos_Entrenamiento[[j]]$fitted.values,
Datos_Entrenamiento$cigs)*100,
THEIL=TheilU(Modelos_Entrenamiento[[j]]$fitted.values,
Datos_Entrenamiento$cigs,type = 1),
Um=Um(Modelos_Entrenamiento[[j]]$fitted.values,
Datos_Entrenamiento$cigs),
Us=Us(Modelos_Entrenamiento[[j]]$fitted.values,
Datos_Entrenamiento$cigs),
Uc=Uc(Modelos_Entrenamiento[[j]]$fitted.values,
Datos_Entrenamiento$cigs)
)
Resultados_Performance[[j]]<-data.frame(
R2 = R2(Pronostico_Prueba[[j]], Datos_Prueba$cigs),
RMSE = RMSE(Pronostico_Prueba[[j]], Datos_Prueba$cigs),
MAE = MAE(Pronostico_Prueba[[j]], Datos_Prueba$cigs),
MAPE= MAPE(Pronostico_Prueba[[j]], Datos_Prueba$cigs)*100,
THEIL=TheilU(Pronostico_Prueba[[j]], Datos_Prueba$cigs,
type = 1),
Um=Um(Pronostico_Prueba[[j]], Datos_Prueba$cigs),
Us=Us(Pronostico_Prueba[[j]], Datos_Prueba$cigs),
Uc=Uc(Pronostico_Prueba[[j]], Datos_Prueba$cigs)
)
}
bind_rows(Resultados_Performance_data_entrenamiento) %>%
stargazer(title= "Medidas de Performance Datos del Modelo", type = "html", digits = 3,summary.stat = c("n","mean","sd","min","p25","p75","max"))
Medidas de Performance Datos del Modelo
|
|
|
Statistic
|
N
|
Mean
|
St. Dev.
|
Min
|
Pctl(25)
|
Pctl(75)
|
Max
|
|
|
|
R2
|
500
|
0.058
|
0.007
|
0.040
|
0.054
|
0.063
|
0.083
|
|
RMSE
|
500
|
13.304
|
0.198
|
12.629
|
13.175
|
13.439
|
13.828
|
|
MAE
|
500
|
10.562
|
0.133
|
10.068
|
10.474
|
10.654
|
10.969
|
|
MAPE
|
500
|
Inf.000
|
|
Inf
|
Inf
|
Inf
|
Inf
|
|
THEIL
|
500
|
0.522
|
0.006
|
0.505
|
0.517
|
0.526
|
0.541
|
|
Um
|
500
|
0.000
|
0.000
|
0
|
0
|
0
|
0
|
|
Us
|
500
|
0.613
|
0.020
|
0.554
|
0.601
|
0.625
|
0.669
|
|
Uc
|
500
|
0.389
|
0.020
|
0.332
|
0.376
|
0.401
|
0.448
|
|
|
- En esta ocasion, las medidad del performance del modelo nos dice que
en promedio el 5,8% de la varianza en Y es representada por los
regresores, obteniendo que en minimo los datos puedes caer en el 4% y el
máximo 8,3%.
- En el modelo original, el indicador MAE dice que en promedio el
modelo se equivoca en 10,5 cigarros fumados por día, pero el indicador
MAPE dice que el modelo tiene un error hacia el infinito al momento de
hacer predicciones, por lo que se concluye que el modelo no funciona en
este caso.
- Y eso se observa en las proporciones, en donde la proporción de
covarianza (Uc) es menor del 90%, con 38,9% y la suma de la proporción
del sesgo (Um) con la proporción de la varianza (Us) es mayor que el
10%, siendo de 61,3% para el modelo.
bind_rows(Resultados_Performance) %>%
stargazer(title = "Medidas de Performance Simulación",
type = "html",
digits = 3,
summary.stat = c("n","mean","sd","min","p25","p75","max"))
Medidas de Performance Simulación
|
|
|
Statistic
|
N
|
Mean
|
St. Dev.
|
Min
|
Pctl(25)
|
Pctl(75)
|
Max
|
|
|
|
R2
|
500
|
0.039
|
0.018
|
0.002
|
0.027
|
0.051
|
0.099
|
|
RMSE
|
500
|
13.479
|
0.595
|
11.734
|
13.064
|
13.853
|
15.361
|
|
MAE
|
500
|
10.728
|
0.290
|
9.834
|
10.528
|
10.904
|
11.626
|
|
MAPE
|
500
|
Inf.000
|
|
Inf
|
Inf
|
Inf
|
Inf
|
|
THEIL
|
500
|
0.528
|
0.013
|
0.491
|
0.519
|
0.536
|
0.564
|
|
Um
|
500
|
0.002
|
0.003
|
0.00000
|
0.0003
|
0.003
|
0.021
|
|
Us
|
500
|
0.597
|
0.051
|
0.476
|
0.563
|
0.636
|
0.751
|
|
Uc
|
500
|
0.405
|
0.051
|
0.253
|
0.367
|
0.441
|
0.529
|
|
|
- En esta ocasion, las medidad del performance de la simulación nos
dicen que en promedio el 3,9% de la varianza en Y es representada por
los regresores, obteniendo que en minimo los datos puedes caer en el
0,2% y el máximo 9%, se puede observar ahora, que la distancia entre el
máximo y percentir 75 es de casi el 5%.
- En el modelo estimado, el indicador MAE dice que en promedio el
modelo se equivoca en 10,7 cigarros fumados por día, pero el indicador
MAPE dice que el modelo simulado erra hacia el infinito al momento de
realizar predicciones, por lo que se concluye que el modelo simulado
tampoco funciona en este caso.
- Y eso se observa en las proporciones, en donde la proporción de
covarianza (Uc) es menor del 90%, con 40,5% y la suma de la proporción
del sesgo (Um) con la proporción de la varianza (Us) es mayor que el
10%, siendo de 59,9%% para este modelo simulado.