Modelo Uniforme Discreto- Mes de Cierre de operaciones
Grupo 1
1.Carga de datos
setwd("/cloud/project/")
datos<-read.csv("DerramesEEUU.csv", header = TRUE, sep=";" , dec=",",na.strings ="-")
str(datos)## 'data.frame': 2760 obs. of 59 variables:
## $ NumeroInforme : int 20100064 20100054 20100092 20100098 20100101 20100102 20100113 20100120 20100039 20100150 ...
## $ NumeroComplementario : int 15072 15114 15120 15127 15130 15132 15146 15162 15197 15205 ...
## $ DiaAccidente : int 8 25 10 28 27 29 11 23 15 11 ...
## $ MesAccidente : int 4 3 5 4 5 5 6 5 3 1 ...
## $ AnioAccidente : int 2010 2010 2010 2010 2010 2010 2010 2010 2010 2010 ...
## $ HoraAccidente : int 6 13 6 24 3 14 7 6 15 2 ...
## $ AmPmAccidente : chr "a. m." "p. m." "a. m." "p. m." ...
## $ IDOperador : int 31684 18779 30829 12105 20160 30003 1248 300 18718 32296 ...
## $ NombreOperador : chr "CONOCOPHILLIPS" "SUNOCO, INC (R&M)" "TEPPCO CRUDE PIPELINE, LLC" "MAGELLAN AMMONIA PIPELINE, L.P." ...
## $ NombreOleoductoInstalacion : chr "GD-03, GOLD LINE" "PHILADELPHIA REFINERY - WEST YARD" "HOBBS TO MIDLAND" "WHITING TO EARLY SEGMENT" ...
## $ UbicacionOleoducto : chr "ONSHORE" "ONSHORE" "ONSHORE" "ONSHORE" ...
## $ TipoOleoducto : chr "ABOVEGROUND" "ABOVEGROUND" "UNDERGROUND" "UNDERGROUND" ...
## $ TipoLiquido : chr "REFINED AND/OR PETROLEUM PRODUCT (NON-HVL), LIQUID" "REFINED AND/OR PETROLEUM PRODUCT (NON-HVL), LIQUID" "CRUDE OIL" "HVL OR OTHER FLAMMABLE OR TOXIC FLUID, GAS" ...
## $ SubtipoLiquido : chr "GASOLINE (NON-ETHANOL)" "OTHER" NA "ANHYDROUS AMMONIA" ...
## $ NombreLiquido : chr NA "VACUUM GAS OIL (VGO)" NA NA ...
## $ CiudadAccidente : chr "GREEN RIDGE" "PHILADELPHIA" "HOBBS" "SCHALLER" ...
## $ CondadoAccidente : chr "PETTIS" "PHILADELPHIA" "LEA" "IDA" ...
## $ EstadoAccidente : chr "MO" "PA" "NM" "IA" ...
## $ LatitudAccidente : num 38.6 39.9 32.6 42.5 30.2 ...
## $ LongitudAccidente : num -93.4 -75.2 -103.1 -95.3 -91.2 ...
## $ CategoriaCausa : chr "NATURAL FORCE DAMAGE" "MATERIAL/WELD/EQUIP FAILURE" "CORROSION" "MATERIAL/WELD/EQUIP FAILURE" ...
## $ SubcategoriaCausa : chr "TEMPERATURE" "NON-THREADED CONNECTION FAILURE" "EXTERNAL" "CONSTRUCTION, INSTALLATION OR FABRICATION-RELATED" ...
## $ LiberacionInvoluntariaBarriles : num 0.24 1700 2 0.36 1.31 ...
## $ LiberacionIntencionalBarriles : chr "0" "0" NA "0.05" ...
## $ RecuperacionLiquidoBarriles : num 0.07 1699 0.48 0 0 ...
## $ PerdidaNetaBarriles : num 0.17 1 1.52 0.36 1.31 ...
## $ IgnicionLiquido : chr "NO" "NO" "NO" "NO" ...
## $ ExplosionLiquido : chr "NO" "NO" "NO" "NO" ...
## $ CierreOleoducto : chr "YES" "YES" "NO" "NO" ...
## $ DiaCierre : int 8 25 NA NA 27 NA NA 23 15 11 ...
## $ MesCierre : int 4 3 NA NA 5 NA NA 5 3 1 ...
## $ AnioCierre : int 2010 2010 NA NA 2010 NA NA 2010 2010 2010 ...
## $ HoraCierre : int 6 18 NA NA 3 NA NA 7 16 2 ...
## $ AmPmCierre : chr "a. m." "p. m." NA NA ...
## $ DiaReinicio : int 9 28 NA NA 27 NA NA 23 15 15 ...
## $ MesReinicio : int 4 3 NA NA 5 NA NA 5 3 1 ...
## $ AnioReinicio : int 2010 2010 NA NA 2010 NA NA 2010 2010 2010 ...
## $ HoraReinicio : int 10 16 NA NA 24 NA NA 9 18 15 ...
## $ AmPmReinicio : chr "a. m." "p. m." NA NA ...
## $ EvacuacionesPublicas : int NA 0 NA NA 0 0 0 0 NA 0 ...
## $ LesionesEmpleadosOperador : int NA NA NA NA NA NA NA NA NA NA ...
## $ LesionesContratistasOperador : int NA NA NA NA NA NA NA NA NA NA ...
## $ LesionesRescatistasEmergencia : int NA NA NA NA NA NA NA NA NA NA ...
## $ OtrasLesiones : int NA NA NA NA NA NA NA NA NA NA ...
## $ LesionesPublico : int NA NA NA NA NA NA NA NA NA NA ...
## $ TodasLesiones : int NA NA NA NA NA NA NA NA NA NA ...
## $ FallecimientosEmpleadosOperador : int NA NA NA NA NA NA NA NA NA NA ...
## $ FallecimientosContratistasOperador : int NA NA NA NA NA NA NA NA NA NA ...
## $ FallecimientosRescatistasEmergencia : int NA NA NA NA NA NA NA NA NA NA ...
## $ OtrosFallecimientos : int NA NA NA NA NA NA NA NA NA NA ...
## $ FallecimientosPublico : int NA NA NA NA NA NA NA NA NA NA ...
## $ TodosFallecimientos : int NA NA NA NA NA NA NA NA NA NA ...
## $ CostosDaniosPropiedad : int 0 0 30000 12000 2720 NA 750 1300 NA 29360 ...
## $ CostosMercanciaPerdidas : int 27 0 100 30 1500 150 300 340 46 136233 ...
## $ CostosDaniosPropiedadesPublicasPrivadas: int 0 0 1000 5000 0 0 0 0 NA NA ...
## $ CostosRespuestaEmergencia : int 0 0 NA 0 1000 NA 400 2445 10999 NA ...
## $ CostosRemediacionAmbiental : int 0 100000 20000 15000 NA NA 6050 3350 452 NA ...
## $ OtrosCostos : int 0 0 NA 0 NA NA 0 2530 NA NA ...
## $ TodosCostos : int 27 100000 51100 32030 5220 150 7500 9965 11497 165593 ...1.1 Extracción de datos
MesCierre <- na.omit(as.numeric(datos$MesCierre))2.Distribución de Frecuencias
Frecuencias Simples
TDFMesCierre <- table(MesCierre)
TablaMesCierre <- as.data.frame(TDFMesCierre)
names(TablaMesCierre) <- c("Mes","ni")
TablaMesCierre$hi_porc <- round((TablaMesCierre$ni / sum(TablaMesCierre$ni)) * 100, 2)Frecuencias acumuladas
TablaMesCierre$Ni_asc <- cumsum(TablaMesCierre$ni)
TablaMesCierre$Ni_dsc <- rev(cumsum(rev(TablaMesCierre$ni)))
TablaMesCierre$Hi_asc <- round(cumsum(TablaMesCierre$hi_porc), 3)
TablaMesCierre$Hi_dsc <- round(rev(cumsum(rev(TablaMesCierre$hi_porc))), 3)Tabla de frecuencias
TDFFinalMes <- rbind(TablaMesCierre, data.frame(
Mes = "TOTAL",
ni = sum(TablaMesCierre$ni),
hi_porc = 100,
Ni_asc = " ",
Ni_dsc = " ",
Hi_asc = " ",
Hi_dsc = " "
))
library(gt)
tabla_MesC <- TDFFinalMes %>%
gt() %>%
cols_label(
Mes = md("**Año**"),
ni = md("**ni**"),
hi_porc = md("**hi (%)**"),
Ni_asc = md("**Ni ↑**"),
Ni_dsc = md("**Ni ↓**"),
Hi_asc = md("**Hi ↑ (%)**"),
Hi_dsc = md("**Hi ↓ (%)**")
) %>%
tab_header(
title = md("**Tabla N°1**"),
subtitle = md("**Distribución de accidentes en oleoductos por año en EE.UU. (2010-2017)**")
) %>%
tab_source_note(
source_note = md("Autor: Grupo 1")
) %>%
tab_options(
table.background.color = "white",
row.striping.background_color = "white",
table.border.top.color = "black",
table.border.bottom.color = "black",
table.border.top.style = "solid",
table.border.bottom.style = "solid",
column_labels.font.weight = "bold",
column_labels.border.top.color = "black",
column_labels.border.bottom.color = "black",
column_labels.border.bottom.width = px(2),
heading.border.bottom.color = "black",
heading.border.bottom.width = px(2),
table_body.hlines.color = "gray",
table_body.border.bottom.color = "black"
) %>%
tab_style(
style = cell_text(weight = "bold"),
locations = cells_body(
rows = as.character(Mes) == "TOTAL"
)
)
tabla_MesC| Tabla N°1 | ||||||
| Distribución de accidentes en oleoductos por año en EE.UU. (2010-2017) | ||||||
| Año | ni | hi (%) | Ni ↑ | Ni ↓ | Hi ↑ (%) | Hi ↓ (%) |
|---|---|---|---|---|---|---|
| 1 | 122 | 8.88 | 122 | 1374 | 8.88 | 100.01 |
| 2 | 114 | 8.30 | 236 | 1252 | 17.18 | 91.13 |
| 3 | 114 | 8.30 | 350 | 1138 | 25.48 | 82.83 |
| 4 | 129 | 9.39 | 479 | 1024 | 34.87 | 74.53 |
| 5 | 104 | 7.57 | 583 | 895 | 42.44 | 65.14 |
| 6 | 102 | 7.42 | 685 | 791 | 49.86 | 57.57 |
| 7 | 111 | 8.08 | 796 | 689 | 57.94 | 50.15 |
| 8 | 125 | 9.10 | 921 | 578 | 67.04 | 42.07 |
| 9 | 125 | 9.10 | 1046 | 453 | 76.14 | 32.97 |
| 10 | 87 | 6.33 | 1133 | 328 | 82.47 | 23.87 |
| 11 | 111 | 8.08 | 1244 | 241 | 90.55 | 17.54 |
| 12 | 130 | 9.46 | 1374 | 130 | 100.01 | 9.46 |
| TOTAL | 1374 | 100.00 | ||||
| Autor: Grupo 1 | ||||||
Gráfica
par(mar = c(6, 6, 4, 2))
barplot(
TablaMesCierre$ni,
main = "Gráfica N°1: Distribución de la cantidad de accidentes
por año en EE.UU.",
xlab = "Año",
ylab = "Cantidad",
col = "slategray1",
names.arg = TablaMesCierre$Mes,
las = 1,
cex.main = 1.2,
cex.lab = 1.2,
cex.axis = 0.8,
cex.names = 0.8
)
3.Conjetura de Modelo
Se conjetura que la variable MesCierre, podría seguir una distribución uniforme discreta, bajo el supuesto de que cada mes tiene la misma probabilidad de registrar un cierre de operaciones. Esta suposición permite analizar si los eventos se encuentran equitativamente distribuidos a lo largo del año.
3.1 Definición de Hipótesis
Hipótesis nula(Ho): Los cierres de operaciones en oleoductos están uniformemente distribuidos a lo largo de los meses del año.
Hipótesis alternativa (H1): Los cierres de operaciones en oleoductos NO siguen una distribución uniforme a lo largo de los meses del año.
3.2 Ajuste del modelo uniforme
Distribución de Frecuencias
- Frecuencias Observadas
Fo <- TablaMesCierre$ni- Frecuencias Esperadas
# Número de categorías (años)
k <- length(Fo)
total_accidentes <- sum(Fo)
Fe <- rep(total_accidentes / k, k)3.3 Gráfica del Modelo
barplot(rbind(Fo, Fe),
beside = TRUE,
col = c("slategray2", "lightcoral"),
names.arg = as.character(TablaMesCierre$Mes),
xlab = "Mes del Cierre de Operaciones",
ylab = "Frecuencia",
las = 1,
cex.names = 0.8,
cex.axis = 1,
ylim= c(0, 180))
title(main = "Gráfica N°2: Comparación Modelo Uniforme vs Observado",
cex.main = 1.2)
legend(x = 27, y = 170,
legend = c("Observado", "Uniforme"),
fill = c("slategray2", "lightcoral"),
bty = "o",
y.intersp = 0.7,
cex = 0.8)
4.Test de Bondad de ajuste
- Estadístico chi-cuadrado
x2_u <- sum((Fo - Fe)^2 / Fe)El estadistico Chi-cuadrado es: 15.50218
- Cálculo del Umbral de Aceptación
Grados de Libertad
gl_u <- (k - 1) Definición del nivel de significancia
nivel_significancia <- 0.05Umbral de aceptación
umbral_aceptacion<- qchisq(1 - nivel_significancia, gl_u)El umbral de aceptación es: 19.67514
4.1 Decisión
if (x2_u < umbral_aceptacion) {
cat("Conclusión: No se rechaza H0, los cierres de operaciones en oleoductos podrian seguir una distribución uniforme a lo largo de los meses de un año.")
} else {
cat("Conclusión: Se rechaza H0, el cierre de operaciones en oleoductos NO siguen una distribución uniforme.")
}Conclusión: No se rechaza H0, los cierres de operaciones en oleoductos podrian seguir una distribución uniforme a lo largo de los meses de un año.
4.2 Tabla resumen de test4
Variable <- c("Mes Cierre")
Modelo <- c("Uniforme")
Tabla_resumen <- data.frame(Variable,
Modelo,
Chi_Cuadrado = round(x2_u,2),
Umbral = round(umbral_aceptacion,2),
TestChi = c("Aprobado"))
colnames(Tabla_resumen) <- c("Variable",
"Modelo",
"Chi-Cuadrado",
"Umbral de aceptación",
"Test de Bondad de ajuste")
library(gt)
Tabla_resumen %>%
gt() %>%
tab_header(
title = md("**Tabla N°2**"),
subtitle = md("**Resumen de los Tests Aplicados al Modelo Uniforme**")
) %>%
tab_source_note(
source_note = md("Autor: Grupo 1")
) %>%
cols_align(
align = "center",
columns = everything()
) %>%
tab_options(
table.border.top.color = "black",
table.border.bottom.color = "black",
table.border.top.style = "solid",
table.border.bottom.style = "solid",
column_labels.font.weight = "bold",
column_labels.border.top.color = "black",
column_labels.border.bottom.color = "black",
column_labels.border.bottom.width = px(2),
heading.border.bottom.color = "black",
heading.border.bottom.width = px(2),
table_body.hlines.color = "grey",
table_body.border.bottom.color = "black"
)| Tabla N°2 | ||||
| Resumen de los Tests Aplicados al Modelo Uniforme | ||||
| Variable | Modelo | Chi-Cuadrado | Umbral de aceptación | Test de Bondad de ajuste |
|---|---|---|---|---|
| Mes Cierre | Uniforme | 15.5 | 19.68 | Aprobado |
| Autor: Grupo 1 | ||||
Los resultados obtenidos indican que la distribución uniforme discreta es adecuada para modelar los datos de la variable Mes Cierre:
El estadístico Chi-cuadrado calculado (15.5) es menor que el umbral de aceptación (19.68), lo que indica que no se rechaza la hipótesis nula (H₀) y el modelo Uniforme es adecuado para describir los datos observados.5.Cálculo de probabilidades
A modo de aplicación del modelo uniforme discreto, se estima la probabilidad de que los accidentes ocurran dentro de un rango específico de meses. Este cálculo no busca validar nuevamente el modelo, sino ilustrar cómo se distribuyen las probabilidades de ocurrencia cuando todos los meses son equiprobables.
- ¿Cuál es la probabilidad de que el cierre de operaciones ocurra entre los meses de junio y agosto (Mes 6 al 8)?
5.1 Estimación de Probabilidad
# Probabilidad de cada mes
p_mes <- 1 / k
# Rango de interés: junio (6) a agosto (8)
mes_inicio <- 6
mes_fin <- 8
# Probabilidad total para el rango
prob_uniforme <- (mes_fin - mes_inicio + 1) * p_mesLa probabilidad de que el cierre de operaciones ocurra entre los meses de junio y agosto es de: 25 %
5.2 Gráfica de Probabilidad
x <- 1:12
# Densidad de probabilidad uniforme
y <- rep(p_mes, k)
# Gráfica
barplot(y,
names.arg = x,
col = ifelse(x >= 6 & x <= 8, "lightcoral", "slategray2"),
main = "Gráfica N°3: Probabilidad uniforme discreta - Mes de Cierre de Operaciones",
xlab = "Mes del Cierre de Operaciones",
ylab = "Densidad de probabilidad",
ylim = c(0, 0.12),
las = 1)
# Leyenda
legend("topright",
legend = c("Meses fuera del rango", "Meses 6 al 8"),
fill = c("skyblue", "lightcoral"),
border = NA,
cex = 0.8)
6.Teorema del Límite Central
El Teorema del Límite Central establece que, aunque las variables individuales de una población no sigan una distribución normal, la distribución de las medias muestrales tiende a ser normal cuando el tamaño de la muestra es suficientemente grande (n ≥ 30).
Por lo tanto, es posible estimar la media poblacional mediante intervalos de confianza, aun cuando la distribución original de los datos no sea normal.Esto se puede hacer con tres postulados principales:
Donde:
- x es la media aritmética muestral
- e es el margen de error de la media
Media aritmética muestral
x <- mean(MesCierre)La media muestral es de: 6.472344
Desviación estándar muestral
sigma_u<- sd(MesCierre)La desviación estandar muestral es de: 3.497627
Error estándar de la media
n <- length(MesCierre)
e <- sigma_u/ sqrt(n)El error estandar de la media es de: 0.0943583
Intervalo de Confianza del 95%
limite_inferior <- x - 2 * e
limite_superior <- x + 2 * eEl limite inferior es: 6.283627
El limite superior es: 6.66106
Tabla
tabla_media_exp <- data.frame(
round(limite_inferior, 2),
round(x, 2),
round(limite_superior, 2),
round(sigma_u, 2)
)
colnames(tabla_media_exp) <- c("Límite inferior", "Media poblacional",
"Límite superior", "Desviación estándar poblacional")
library(gt)
tabla_media_exp%>%
gt() %>%
tab_header(
title = md("**Tabla N°3**"),
subtitle = md("**Parametros poblacionales de la variable **MesCierre** de los accidentes en oleoductos ocurridos en EE.UU.(2010-2017)**")
) %>%
tab_source_note(
source_note = md("Autor: Grupo 1")
) %>%
cols_align(
align = "center",
columns = everything()
) %>%
tab_options(
table.border.top.color = "black",
table.border.bottom.color = "black",
table.border.top.style = "solid",
table.border.bottom.style = "solid",
column_labels.font.weight = "bold",
column_labels.border.top.color = "black",
column_labels.border.bottom.color = "black",
column_labels.border.bottom.width = px(2),
heading.border.bottom.color = "black",
heading.border.bottom.width = px(2),
table_body.hlines.color = "grey",
table_body.border.bottom.color = "black"
)| Tabla N°3 | |||
| Parametros poblacionales de la variable MesCierre de los accidentes en oleoductos ocurridos en EE.UU.(2010-2017) | |||
| Límite inferior | Media poblacional | Límite superior | Desviación estándar poblacional |
|---|---|---|---|
| 6.28 | 6.47 | 6.66 | 3.5 |
| Autor: Grupo 1 | |||
7.Conclusión
La variable MesCierre se ajusta a una distribución uniforme discreta, con una media poblacional 6.47 y una desviación estándar poblacional de 3.5.
De acuerdo con este modelo, se determinó que la probabilidad de que el cierre de operaciones ocurra entre los meses de junio y agosto es del 25%, lo que ilustra la distribución de la probabilidad en un rango específico bajo la suposición de equiprobabilidad.
Al aplicar el Teorema del Límite Central, se estimó que la media poblacional se encuentra entre el mes 6.28 y 6.66 (aproximadamente, la segunda mitad de junio a la mitad de julio) con un 95% de confianza.
Esta estimación del intervalo de confianza para la media sugiere que,
en promedio, el cierre de operaciones se concentra levemente hacia la
mitad del año (verano), incluso bajo la suposición teórica de un modelo
de probabilidad uniforme.