Trabajo_Final
Esteban Babativa
2023-06-18
Trabajo Final
#Muestreo sistemático y estratificado de la base de datos vinos
librerias a utilizar
library(readr)## Warning: package 'readr' was built under R version 4.1.3library(ggplot2)## Warning: package 'ggplot2' was built under R version 4.1.3library(dplyr)## Warning: package 'dplyr' was built under R version 4.1.3##
## Attaching package: 'dplyr'## The following objects are masked from 'package:stats':
##
## filter, lag## The following objects are masked from 'package:base':
##
## intersect, setdiff, setequal, unionlibrary(TeachingSampling)## Warning: package 'TeachingSampling' was built under R version 4.1.3## Loading required package: magrittr## Warning: package 'magrittr' was built under R version 4.1.3library(sampling)## Warning: package 'sampling' was built under R version 4.1.3Base de datos
winequality.red <- read.csv("C:/Users/Usuario/Desktop/winequality-red.csv", sep=";")
View(winequality.red)Estructura de la base , tipo de datos y datos faltantes , analisis descriptivo
# Análisis descriptivo
summary(winequality.red)## fixed.acidity volatile.acidity citric.acid residual.sugar
## Min. : 4.60 Min. :0.1200 Min. :0.000 Min. : 0.900
## 1st Qu.: 7.10 1st Qu.:0.3900 1st Qu.:0.090 1st Qu.: 1.900
## Median : 7.90 Median :0.5200 Median :0.260 Median : 2.200
## Mean : 8.32 Mean :0.5278 Mean :0.271 Mean : 2.539
## 3rd Qu.: 9.20 3rd Qu.:0.6400 3rd Qu.:0.420 3rd Qu.: 2.600
## Max. :15.90 Max. :1.5800 Max. :1.000 Max. :15.500
## chlorides free.sulfur.dioxide total.sulfur.dioxide density
## Min. :0.01200 Min. : 1.00 Min. : 6.00 Min. :0.9901
## 1st Qu.:0.07000 1st Qu.: 7.00 1st Qu.: 22.00 1st Qu.:0.9956
## Median :0.07900 Median :14.00 Median : 38.00 Median :0.9968
## Mean :0.08747 Mean :15.87 Mean : 46.47 Mean :0.9967
## 3rd Qu.:0.09000 3rd Qu.:21.00 3rd Qu.: 62.00 3rd Qu.:0.9978
## Max. :0.61100 Max. :72.00 Max. :289.00 Max. :1.0037
## pH sulphates alcohol quality
## Min. :2.740 Min. :0.3300 Min. : 8.40 Min. :3.000
## 1st Qu.:3.210 1st Qu.:0.5500 1st Qu.: 9.50 1st Qu.:5.000
## Median :3.310 Median :0.6200 Median :10.20 Median :6.000
## Mean :3.311 Mean :0.6581 Mean :10.42 Mean :5.636
## 3rd Qu.:3.400 3rd Qu.:0.7300 3rd Qu.:11.10 3rd Qu.:6.000
## Max. :4.010 Max. :2.0000 Max. :14.90 Max. :8.000# Tabla de frecuencias con respecto a la variable calidad
table(winequality.red$quality)##
## 3 4 5 6 7 8
## 10 53 681 638 199 18# Histograma con respecto a la variable calidad
hist(winequality.red$quality)
# Verificar si hay datos faltantes o NA en cada columna
colSums(is.na(winequality.red))## fixed.acidity volatile.acidity citric.acid
## 0 0 0
## residual.sugar chlorides free.sulfur.dioxide
## 0 0 0
## total.sulfur.dioxide density pH
## 0 0 0
## sulphates alcohol quality
## 0 0 0# Contar el número de filas con datos faltantes o NA
sum(rowSums(is.na(winequality.red)) > 0)## [1] 0# Ver el tipo de datos de cada variable
str(winequality.red)## 'data.frame': 1599 obs. of 12 variables:
## $ fixed.acidity : num 7.4 7.8 7.8 11.2 7.4 7.4 7.9 7.3 7.8 7.5 ...
## $ volatile.acidity : num 0.7 0.88 0.76 0.28 0.7 0.66 0.6 0.65 0.58 0.5 ...
## $ citric.acid : num 0 0 0.04 0.56 0 0 0.06 0 0.02 0.36 ...
## $ residual.sugar : num 1.9 2.6 2.3 1.9 1.9 1.8 1.6 1.2 2 6.1 ...
## $ chlorides : num 0.076 0.098 0.092 0.075 0.076 0.075 0.069 0.065 0.073 0.071 ...
## $ free.sulfur.dioxide : num 11 25 15 17 11 13 15 15 9 17 ...
## $ total.sulfur.dioxide: num 34 67 54 60 34 40 59 21 18 102 ...
## $ density : num 0.998 0.997 0.997 0.998 0.998 ...
## $ pH : num 3.51 3.2 3.26 3.16 3.51 3.51 3.3 3.39 3.36 3.35 ...
## $ sulphates : num 0.56 0.68 0.65 0.58 0.56 0.56 0.46 0.47 0.57 0.8 ...
## $ alcohol : num 9.4 9.8 9.8 9.8 9.4 9.4 9.4 10 9.5 10.5 ...
## $ quality : int 5 5 5 6 5 5 5 7 7 5 ...Vemos que como resultado no tenemos datos faltantes y que tenemos varibales de tipo numerico , contamos con 12 variables con 1599 observaciones
Muestreo sistematico
- definir el total de la poblacion
N <- ceiling(nrow(winequality.red)); N## [1] 1599- Se define el tamaño de muestra deseado, en este caso la base de datos tiene 1599 datos, para efectos del ejercicio considero utilizar una muestra de alrededor del 30% de los datos. lo cual nos da como resultado un tamaño de muestra de 480
# Porcentaje de la muestra deseada
porcentaje_muestra <- 0.3
# Cálculo del tamaño de la muestra
tamano_muestra <- round(N * porcentaje_muestra)
tamano_muestra## [1] 480- Se calcula el intervalo de muestreo N/n , el cual nos da como resultado 4
# Cálculo del intervalo de muestreo
intervalo <- ceiling(N / tamano_muestra)
intervalo## [1] 4- Seleccionamos un número inicial aleatorio y creamos una semilla para reproducibilidad
set.seed(123)
numero_inicial <- sample(1:intervalo, 1)- Generamos una secuencia de índices utilizando el muestreo sistemático
# Generar la secuencia de índices de muestreo
indices_muestreo <- seq(from = 1, to = N, by = intervalo)- Realizamos la extraccion de los datos de la muestra de la base de datos original y verificamos el tamaño de la muestra
# Extraer la muestra sistemática
muestra_sistematica <- winequality.red[indices_muestreo, ]
# Verificar el tamaño de la muestra
tamaño_muestra <-nrow(muestra_sistematica)
tamaño_muestra## [1] 400#Una vez seleccionada la muestra representativa, implentamos el método estratificado para obtener subconjuntos , para este ejercicio decidi hacer una estratificacion con respecto a la calidad del vino “quality”
- Crear estratos en función de la variable “quality”
e1 <- filter(muestra_sistematica, quality == 5)
e2 <- filter(muestra_sistematica, quality == 6)
e3 <- filter(muestra_sistematica, quality == 7)Tamaños de los estratos
Ni <- c(nrow(e1), nrow(e2), nrow(e3)); Ni## [1] 171 166 46N1=nrow(e1)
N2=nrow(e2)
N3=nrow(e3)Tamaño de la muestra total
Nm <- sum(Ni); Nm## [1] 383realizaremos un prueba piloto para asegurar la calidad y validez del estudio Tamaño de muestra en cada estrato y en su media
n1=N1*0.1
n2=N2*0.1
n3=N3*0.1
st1=sample(e1$`volatile.acidity`,n1,replace = FALSE)
st2=sample(e2$`volatile.acidity`,n2,replace = FALSE)
st3=sample(e3$`volatile.acidity`,n3,replace = FALSE)
yi <- c(mean(st1), mean(st2), mean(st3))
cbind(yi)## yi
## [1,] 0.6170588
## [2,] 0.5256250
## [3,] 0.4200000Cálculo de la media y varianza de la prueba piloto de muestreo estratificado
y_stpl <- sum(Ni * yi) / Nm
y_stpl## [1] 0.5537619E<-0.05*(y_stpl)
E## [1] 0.0276881NC<-0.95
z<-abs(qnorm((1-NC)/2, mean = 0, sd = 1))
V<-(E/z)^2
V## [1] 0.0001995676n0 <-((N1/Nm)*var(e1$`volatile.acidity`)+(N2/Nm)*var(e2$`volatile.acidity`)+(N3/Nm)*var(e3$`volatile.acidity`))
n0<-n0*(1/V)
nm<-n0/(1+n0/Nm)
nm## [1] 92.3382analisis utilizando las cantidades reales Media de cada estrato
n1=(1/3)*171
n2=(1/3)*166
n3=(1/3)*46
ni <- c(681,638,199)set.seed(1234)
st1=sample(e1$`volatile.acidity`,n1,replace = FALSE)
st2=sample(e2$`volatile.acidity`,n2,replace = FALSE)
st3=sample(e3$`volatile.acidity`,n3,replace = FALSE)
yi <- c(mean(st1), mean(st2), mean(st3))
cbind(yi)## yi
## [1,] 0.6015789
## [2,] 0.4783636
## [3,] 0.3806667Varianza muestral de cada estrato
s2i <- c(var(e1$`volatile.acidity`), var(e2$`volatile.acidity`), var(e3$`volatile.acidity`))
cbind(s2i) ## s2i
## [1,] 0.03076213
## [2,] 0.01956023
## [3,] 0.01723117Cálculo de la media poblacional del estudio de muestreo estratificado
y_st <- sum(Ni * yi) / Nm
y_st## [1] 0.5216424Cálculo de la varianza estimada de la media poblacional
V_yst <- (1/Nm^2) * sum(Ni^2 * (1 - ni/Ni) * (s2i/ni))
confidence_level <- 0.95Valor crítico de la distribución normal estándar
Z <- abs(qnorm((1 - confidence_level) / 2, mean = 0, sd = 1))
cbind(y_st-Z*V_yst,y_st,
y_st+Z*V_yst)## y_st
## [1,] 0.5217353 0.5216424 0.5215495Intervalos de confianza
intervalos_confianza <- matrix(c(y_st - Z * sqrt(V_yst), y_st + Z * sqrt(V_yst)), ncol = 2, byrow = TRUE)## Warning in sqrt(V_yst): Se han producido NaNs
## Warning in sqrt(V_yst): Se han producido NaNsResultados
cat("Media poblacional del estudio de muestreo estratificado:", y_st, "\n")## Media poblacional del estudio de muestreo estratificado: 0.5216424cat("Varianza estimada de la media poblacional:", V_yst, "\n")## Varianza estimada de la media poblacional: -4.738618e-05