Contexto

El Hotel Mirage tiene como necesidad la de conocer la demanda de sus servicios durante el tiempo para asignar mayor o menor cantidad de presupuesto para su operatividad. Cabe mencionar que el hotel cuenta con solamente información de los 12 meses en los que ha estado operativo (es un hotel nuevo).

Mes y Porcentaje de ocupación:

  • Ene: 78
  • Feb: 82
  • Mar: 75
  • Abr: 80
  • May: 85
  • Jun: 88
  • Jul: 92
  • Ago: 90
  • Sep: 86
  • Oct: 84
  • Nov: 80
  • Dic: 83

Ejecución del código

Llamar Librerías

#install.packages("boot")
library(boot)

Calcular media y aplicar bootstrapping

  1. Realice un bootstrapp con 1000 repeticiones con reemplazo
ocupacion <- c(78, 82, 75, 80, 85, 88, 92, 90, 86, 84, 80, 83)

#Función para calcular la media
bootstrap_media <- function(data, indices) {
  return(mean(data[indices]))  
}

#Aplicar Bootstrap con 1000 repeticiones
set.seed(386) 
Rbootstrap <- boot(data = ocupacion, statistic = bootstrap_media, R = 1000)

#Mostrar resumen de resultados
print(Rbootstrap)
## 
## ORDINARY NONPARAMETRIC BOOTSTRAP
## 
## 
## Call:
## boot(data = ocupacion, statistic = bootstrap_media, R = 1000)
## 
## 
## Bootstrap Statistics :
##     original     bias    std. error
## t1* 83.58333 0.02841667     1.38836

calcular intervalos de confianza

#Calcular Intervalo de Confianza del 95%
intervalo_conf <- boot.ci(Rbootstrap, type = "perc")
print(intervalo_conf)
## BOOTSTRAP CONFIDENCE INTERVAL CALCULATIONS
## Based on 1000 bootstrap replicates
## 
## CALL : 
## boot.ci(boot.out = Rbootstrap, type = "perc")
## 
## Intervals : 
## Level     Percentile     
## 95%   (80.92, 86.42 )  
## Calculations and Intervals on Original Scale
hist(Rbootstrap$t, main = "Distribución Bootstrap de la Media",
     xlab = "Media Remuestreada", col = "powderblue", border = "black")

  1. ¿Cuál es el rango en el que podría esperarse que esté la ocupación hotelera para el siguiente mes?

Intervalo al 95% de confianza según los calculos: (80.92, 86.42 )

Ejecución de Código: Bootstrapping con 100,000 repeticiones

Calcular media y aplicar bootstrapping (100000)

#Aplicar Bootstrap con 1000 repeticiones
set.seed(386) 
Rbootstrap2 <- boot(data = ocupacion, statistic = bootstrap_media, R = 100000)

#Mostrar resumen de resultados
print(Rbootstrap2)
## 
## ORDINARY NONPARAMETRIC BOOTSTRAP
## 
## 
## Call:
## boot(data = ocupacion, statistic = bootstrap_media, R = 1e+05)
## 
## 
## Bootstrap Statistics :
##     original       bias    std. error
## t1* 83.58333 -0.003481667    1.377706

calcular intervalos de confianza

#Calcular Intervalo de Confianza del 95%
intervalo_conf2 <- boot.ci(Rbootstrap2, type = "perc")
print(intervalo_conf2)
## BOOTSTRAP CONFIDENCE INTERVAL CALCULATIONS
## Based on 100000 bootstrap replicates
## 
## CALL : 
## boot.ci(boot.out = Rbootstrap2, type = "perc")
## 
## Intervals : 
## Level     Percentile     
## 95%   (80.92, 86.25 )  
## Calculations and Intervals on Original Scale
hist(Rbootstrap2$t, main = "Distribución Bootstrap de la Media",
     xlab = "Media Remuestreada", col = "pink", border = "black")

En este caso el cambio de 1000 a 100,000 iteraciones no tuvo un cambio significativo.

Comparativa:

  • 1000: (80.92, 86.42 )
  • 100,000: (80.92, 86.25 )

Pregunta Final

El dueño del hotel se dio cuenta de que la ocupación hotelera para el mes de diciembre no fue de 83%, si no de 73%, ¿Cómo cambian los resultados (volver a hacer el ejercicio)?

ocupacion3 <- c(78, 82, 75, 80, 85, 88, 92, 90, 86, 84, 80, 73)

#Función para calcular la media
bootstrap_media3 <- function(data, indices) {
  return(mean(data[indices]))  
}

#Aplicar Bootstrap con 1000 repeticiones
set.seed(386) 
Rbootstrap3 <- boot(data = ocupacion3, statistic = bootstrap_media3, R = 100000)

#Mostrar resumen de resultados
print(Rbootstrap3)
## 
## ORDINARY NONPARAMETRIC BOOTSTRAP
## 
## 
## Call:
## boot(data = ocupacion3, statistic = bootstrap_media3, R = 1e+05)
## 
## 
## Bootstrap Statistics :
##     original    bias    std. error
## t1*    82.75 -0.003465    1.621605
#Calcular Intervalo de Confianza del 95%
intervalo_conf3 <- boot.ci(Rbootstrap3, type = "perc")
print(intervalo_conf3)
## BOOTSTRAP CONFIDENCE INTERVAL CALCULATIONS
## Based on 100000 bootstrap replicates
## 
## CALL : 
## boot.ci(boot.out = Rbootstrap3, type = "perc")
## 
## Intervals : 
## Level     Percentile     
## 95%   (79.58, 85.92 )  
## Calculations and Intervals on Original Scale
hist(Rbootstrap3$t, main = "Distribución Bootstrap de la Media",
     xlab = "Media Remuestreada", col = "violetred", border = "black")

Resultados (Tercer Bootstrap):

  • 1000 iteraciones:

Al cambiar el mes de diciembre el resultado de la media cambia a 82.75, una diferencia de 1 unidad. En cuanto a intervalos, este caso resultó un intervalo de (79.59, 86.08 )

  • 100,000 iteraciones:

Con el cambio anterior y 100,000 iteraciones el resultado de la media se mantiene en 82.75 y los intervalos en (79.58, 85.92 )

LS0tDQp0aXRsZTogIkJvb3RzdHJhcHBpbmdfT2N1cGFjaW9uX0hvdGVsZXJhIg0KYXV0aG9yOiAiU2FtYW50aGEgLSBBMDE0MjI3NDkiDQpkYXRlOiAiMjAyNS0wOC0xOSINCm91dHB1dDoNCiAgaHRtbF9kb2N1bWVudDoNCiAgICAgdG9jOiBUUlVFDQogICAgIHRvY19mbG9hdDogVFJVRQ0KICAgICBjb2RlX2Rvd25sb2FkOiBUUlVFDQogICAgIHRoZW1lOiB5ZXRpDQotLS0NCiFbXShodHRwczovL2kuaW1ndXIuY29tL3ZLWDJUN1AuZ2lmKQ0KDQojIDxzcGFuIHN0eWxlPSJjb2xvcjogbGlnaHRncmVlbiA7Ij4gQ29udGV4dG8gPC9zcGFuPg0KDQpFbCBIb3RlbCBNaXJhZ2UgdGllbmUgY29tbyBuZWNlc2lkYWQgbGEgZGUgY29ub2NlciBsYSBkZW1hbmRhIGRlIHN1cyBzZXJ2aWNpb3MgZHVyYW50ZSBlbCB0aWVtcG8gcGFyYSBhc2lnbmFyIG1heW9yIG8gbWVub3IgY2FudGlkYWQgZGUgcHJlc3VwdWVzdG8gcGFyYSBzdSBvcGVyYXRpdmlkYWQuIENhYmUgbWVuY2lvbmFyIHF1ZSBlbCBob3RlbCBjdWVudGEgY29uIHNvbGFtZW50ZSBpbmZvcm1hY2nDs24gZGUgbG9zIDEyIG1lc2VzIGVuIGxvcyBxdWUgaGEgZXN0YWRvIG9wZXJhdGl2byAoZXMgdW4gaG90ZWwgbnVldm8pLg0KDQpNZXMgeSBQb3JjZW50YWplIGRlIG9jdXBhY2nDs246DQoNCiogRW5lOiA3OA0KKiBGZWI6IDgyDQoqIE1hcjogNzUgDQoqIEFicjogODANCiogTWF5OiA4NQ0KKiBKdW46IDg4DQoqIEp1bDogOTINCiogQWdvOiA5MA0KKiBTZXA6IDg2DQoqIE9jdDogODQNCiogTm92OiA4MA0KKiBEaWM6IDgzDQoNCiMgPHNwYW4gc3R5bGU9ImNvbG9yOiBncmVlbiA7Ij4gRWplY3VjacOzbiBkZWwgY8OzZGlnbyA8L3NwYW4+DQoNCiMjIDxzcGFuIHN0eWxlPSJjb2xvcjogcmVkIDsiPiBMbGFtYXIgTGlicmVyw61hcyA8L3NwYW4+DQpgYGB7cn0NCiNpbnN0YWxsLnBhY2thZ2VzKCJib290IikNCmxpYnJhcnkoYm9vdCkNCmBgYA0KDQojIyA8c3BhbiBzdHlsZT0iY29sb3I6IGJsYWNrIDsiPiBDYWxjdWxhciBtZWRpYSB5IGFwbGljYXIgYm9vdHN0cmFwcGluZyAgPC9zcGFuPg0KDQoxLiBSZWFsaWNlIHVuIGJvb3RzdHJhcHAgY29uICoqMTAwMCoqIHJlcGV0aWNpb25lcyBjb24gcmVlbXBsYXpvDQoNCmBgYHtyfQ0Kb2N1cGFjaW9uIDwtIGMoNzgsIDgyLCA3NSwgODAsIDg1LCA4OCwgOTIsIDkwLCA4NiwgODQsIDgwLCA4MykNCg0KI0Z1bmNpw7NuIHBhcmEgY2FsY3VsYXIgbGEgbWVkaWENCmJvb3RzdHJhcF9tZWRpYSA8LSBmdW5jdGlvbihkYXRhLCBpbmRpY2VzKSB7DQogIHJldHVybihtZWFuKGRhdGFbaW5kaWNlc10pKSAgDQp9DQoNCiNBcGxpY2FyIEJvb3RzdHJhcCBjb24gMTAwMCByZXBldGljaW9uZXMNCnNldC5zZWVkKDM4NikgDQpSYm9vdHN0cmFwIDwtIGJvb3QoZGF0YSA9IG9jdXBhY2lvbiwgc3RhdGlzdGljID0gYm9vdHN0cmFwX21lZGlhLCBSID0gMTAwMCkNCg0KI01vc3RyYXIgcmVzdW1lbiBkZSByZXN1bHRhZG9zDQpwcmludChSYm9vdHN0cmFwKQ0KYGBgDQoNCiMjIDxzcGFuIHN0eWxlPSJjb2xvcjogYmxhY2sgOyI+IGNhbGN1bGFyIGludGVydmFsb3MgZGUgY29uZmlhbnphICA8L3NwYW4+DQpgYGB7cn0NCiNDYWxjdWxhciBJbnRlcnZhbG8gZGUgQ29uZmlhbnphIGRlbCA5NSUNCmludGVydmFsb19jb25mIDwtIGJvb3QuY2koUmJvb3RzdHJhcCwgdHlwZSA9ICJwZXJjIikNCnByaW50KGludGVydmFsb19jb25mKQ0KDQoNCmhpc3QoUmJvb3RzdHJhcCR0LCBtYWluID0gIkRpc3RyaWJ1Y2nDs24gQm9vdHN0cmFwIGRlIGxhIE1lZGlhIiwNCiAgICAgeGxhYiA9ICJNZWRpYSBSZW11ZXN0cmVhZGEiLCBjb2wgPSAicG93ZGVyYmx1ZSIsIGJvcmRlciA9ICJibGFjayIpDQpgYGANCg0KMi4gwr9DdcOhbCBlcyBlbCByYW5nbyBlbiBlbCBxdWUgcG9kcsOtYSBlc3BlcmFyc2UgcXVlIGVzdMOpIGxhIG9jdXBhY2nDs24gaG90ZWxlcmEgcGFyYSBlbCBzaWd1aWVudGUgbWVzPyANCg0KSW50ZXJ2YWxvIGFsIDk1JSBkZSBjb25maWFuemEgc2Vnw7puIGxvcyBjYWxjdWxvczogKDgwLjkyLCA4Ni40MiApDQoNCiMgPHNwYW4gc3R5bGU9ImNvbG9yOiBibGFjayA7Ij5FamVjdWNpw7NuIGRlIEPDs2RpZ286IEJvb3RzdHJhcHBpbmcgY29uIDEwMCwwMDAgcmVwZXRpY2lvbmVzICA8L3NwYW4+DQoNCiMjIDxzcGFuIHN0eWxlPSJjb2xvcjogYmxhY2sgOyI+IENhbGN1bGFyIG1lZGlhIHkgYXBsaWNhciBib290c3RyYXBwaW5nICgxMDAwMDApICA8L3NwYW4+DQpgYGB7cn0NCg0KI0FwbGljYXIgQm9vdHN0cmFwIGNvbiAxMDAwIHJlcGV0aWNpb25lcw0Kc2V0LnNlZWQoMzg2KSANClJib290c3RyYXAyIDwtIGJvb3QoZGF0YSA9IG9jdXBhY2lvbiwgc3RhdGlzdGljID0gYm9vdHN0cmFwX21lZGlhLCBSID0gMTAwMDAwKQ0KDQojTW9zdHJhciByZXN1bWVuIGRlIHJlc3VsdGFkb3MNCnByaW50KFJib290c3RyYXAyKQ0KYGBgDQoNCiMjIDxzcGFuIHN0eWxlPSJjb2xvcjogYmxhY2sgOyI+IGNhbGN1bGFyIGludGVydmFsb3MgZGUgY29uZmlhbnphICA8L3NwYW4+DQpgYGB7cn0NCiNDYWxjdWxhciBJbnRlcnZhbG8gZGUgQ29uZmlhbnphIGRlbCA5NSUNCmludGVydmFsb19jb25mMiA8LSBib290LmNpKFJib290c3RyYXAyLCB0eXBlID0gInBlcmMiKQ0KcHJpbnQoaW50ZXJ2YWxvX2NvbmYyKQ0KDQoNCmhpc3QoUmJvb3RzdHJhcDIkdCwgbWFpbiA9ICJEaXN0cmlidWNpw7NuIEJvb3RzdHJhcCBkZSBsYSBNZWRpYSIsDQogICAgIHhsYWIgPSAiTWVkaWEgUmVtdWVzdHJlYWRhIiwgY29sID0gInBpbmsiLCBib3JkZXIgPSAiYmxhY2siKQ0KYGBgDQoNCkVuIGVzdGUgY2FzbyBlbCBjYW1iaW8gZGUgMTAwMCBhIDEwMCwwMDAgaXRlcmFjaW9uZXMgbm8gdHV2byB1biBjYW1iaW8gc2lnbmlmaWNhdGl2by4NCiANCkNvbXBhcmF0aXZhOiANCiANCiogMTAwMDogKDgwLjkyLCA4Ni40MiApIA0KKiAxMDAsMDAwOiAoODAuOTIsIDg2LjI1ICkgIA0KDQoNCiMgPHNwYW4gc3R5bGU9ImNvbG9yOiBwaW5rIDsiPiBQcmVndW50YSBGaW5hbCA8L3NwYW4+DQoNCkVsIGR1ZcOxbyBkZWwgaG90ZWwgc2UgZGlvIGN1ZW50YSBkZSBxdWUgbGEgb2N1cGFjacOzbiBob3RlbGVyYSBwYXJhIGVsIG1lcyBkZSBkaWNpZW1icmUgbm8gZnVlIGRlICo4MyUqLCBzaSBubyBkZSAqNzMlKiwgKirCv0PDs21vIGNhbWJpYW4gbG9zIHJlc3VsdGFkb3MgKHZvbHZlciBhIGhhY2VyIGVsIGVqZXJjaWNpbyk/KioNCg0KYGBge3J9DQpvY3VwYWNpb24zIDwtIGMoNzgsIDgyLCA3NSwgODAsIDg1LCA4OCwgOTIsIDkwLCA4NiwgODQsIDgwLCA3MykNCg0KI0Z1bmNpw7NuIHBhcmEgY2FsY3VsYXIgbGEgbWVkaWENCmJvb3RzdHJhcF9tZWRpYTMgPC0gZnVuY3Rpb24oZGF0YSwgaW5kaWNlcykgew0KICByZXR1cm4obWVhbihkYXRhW2luZGljZXNdKSkgIA0KfQ0KDQojQXBsaWNhciBCb290c3RyYXAgY29uIDEwMDAgcmVwZXRpY2lvbmVzDQpzZXQuc2VlZCgzODYpIA0KUmJvb3RzdHJhcDMgPC0gYm9vdChkYXRhID0gb2N1cGFjaW9uMywgc3RhdGlzdGljID0gYm9vdHN0cmFwX21lZGlhMywgUiA9IDEwMDAwMCkNCg0KI01vc3RyYXIgcmVzdW1lbiBkZSByZXN1bHRhZG9zDQpwcmludChSYm9vdHN0cmFwMykNCg0KI0NhbGN1bGFyIEludGVydmFsbyBkZSBDb25maWFuemEgZGVsIDk1JQ0KaW50ZXJ2YWxvX2NvbmYzIDwtIGJvb3QuY2koUmJvb3RzdHJhcDMsIHR5cGUgPSAicGVyYyIpDQpwcmludChpbnRlcnZhbG9fY29uZjMpDQoNCg0KaGlzdChSYm9vdHN0cmFwMyR0LCBtYWluID0gIkRpc3RyaWJ1Y2nDs24gQm9vdHN0cmFwIGRlIGxhIE1lZGlhIiwNCiAgICAgeGxhYiA9ICJNZWRpYSBSZW11ZXN0cmVhZGEiLCBjb2wgPSAidmlvbGV0cmVkIiwgYm9yZGVyID0gImJsYWNrIikNCmBgYA0KIA0KUmVzdWx0YWRvcyAoVGVyY2VyIEJvb3RzdHJhcCk6IA0KDQoqIDEwMDAgaXRlcmFjaW9uZXM6DQoNCkFsIGNhbWJpYXIgZWwgbWVzIGRlIGRpY2llbWJyZSBlbCByZXN1bHRhZG8gZGUgbGEgbWVkaWEgY2FtYmlhIGEgODIuNzUsIHVuYSBkaWZlcmVuY2lhIGRlIDEgdW5pZGFkLiBFbiBjdWFudG8gYSBpbnRlcnZhbG9zLCBlc3RlIGNhc28gcmVzdWx0w7MgdW4gaW50ZXJ2YWxvIGRlICg3OS41OSwgODYuMDggKSAgDQoNCiogMTAwLDAwMCBpdGVyYWNpb25lczoNCg0KQ29uIGVsIGNhbWJpbyBhbnRlcmlvciB5IDEwMCwwMDAgaXRlcmFjaW9uZXMgZWwgcmVzdWx0YWRvIGRlIGxhIG1lZGlhIHNlIG1hbnRpZW5lIGVuIDgyLjc1IHkgbG9zIGludGVydmFsb3MgZW4gKDc5LjU4LCA4NS45MiApDQoNCg0K