Actividad 1

Selección de una muestra con una precisión relativa de $\pm8\%$ y una confiabilidad del $90\%$

El cálculo del tamaño de muestra para estimar un total $t$ es \[n=\frac{N^2S^2}{\frac{\delta^2}{z^2_{1-\alpha/2}}+NS^2}\]

options(scipen = 100)
library(readxl)
Gto2018 <- read_excel("/Users/omardelariva/Library/CloudStorage/GoogleDrive-odelariva@ciencias.unam.mx/My Drive/Documentos Personales/Seminario-Semestre_2022-2/Gto2018_GobSecc.xlsx")

delta.precision<-sum(Gto2018$LISTA_NOMINAL_2018)*0.08
N<-nrow(Gto2018)

n<-ceiling( {N^2*var(Gto2018$LISTA_NOMINAL_2018)}/{(delta.precision/qnorm(0.95))^2+N*var(Gto2018$LISTA_NOMINAL_2018)}
)

library(sampling)

t_x<-sum(Gto2018$LISTA_NOMINAL_2018)

set.seed(10)
s<-srswor(n,N)

pi_k<-(n/N)
Gto2018.muestra<-Gto2018[s==1,]
sum(Gto2018.muestra$LISTA_NOMINAL_2018/pi_k)

## [1] 4234626

hat.t_x<-sum(Gto2018.muestra$LISTA_NOMINAL_2018)/pi_k

c<-abs(t_x-hat.t_x)/t_x

La diferencia \[\left|\sum_{k\in s}\frac{x_k}{\pi_k}-\sum_{k\in U}x_k \right|\big/\sum_{k\in U}x_k <0.02057203\]

Se espera la misma precisión para la estimación de la variable de interés.

hat.t_y<-sum(Gto2018.muestra$PRI)/pi_k

var.hat.t_y<-N^2*(1-n/N)*(var(Gto2018.muestra$PRI)/n)

LI<-hat.t_y-qnorm(0.95)*sqrt(var.hat.t_y)

LS<-hat.t_y+qnorm(0.95)*sqrt(var.hat.t_y)

t_y<-sum(Gto2018$PRI)

El intervalo de confianza del $90\%$ tiene como limites

$LI =$ 258923.5330904

$LS =$ 302788.1395074

El total poblacional es 291987 (votos PRI) que se encuentra en el intervalo de confianza. La precisión relativa es 0.0381221 que se cumple con la precisión no sea mayor a $0.08$

Actividad II

El primer paso es crear la estratificación del marco muestral

Método Geométrico

Se usa la variable LISTA_NOMINAL_2018 Arbitrariamente se eligen 4 Estratos

H<-4
raz<-(max(Gto2018$LISTA_NOMINAL_2018)/ min(Gto2018$LISTA_NOMINAL_2018))^(1/H)
v0<-min(Gto2018$LISTA_NOMINAL_2018)

CORTE_G<- v0*raz^(0:H)

round(CORTE_G,0)

## [1]   100   353  1246  4398 15522

Gto2018$ESTRATO_GEO<-cut(Gto2018$LISTA_NOMINAL_2018,
              c(100, 353, 1246, 4398, Inf), include.lowest = TRUE, right = FALSE,dig.lab = 5)

Descripción gráfica de los estratos

#Tamaño de los estratos con el método geométrico

FREC_GEO <- as.data.frame(table(Gto2018$ESTRATO_GEO)) 

names(FREC_GEO)<-c("ESTRATOS_GEO", "Frecuencia")
# Plot
library(ggplot2)

ggplot(FREC_GEO, aes(x=`ESTRATOS_GEO`, y=Frecuencia)) + geom_point(size=1) + geom_segment(aes(x=`ESTRATOS_GEO`,
xend=`ESTRATOS_GEO`, y=0, yend=Frecuencia)) +
labs(title="Estratos de casillas",
subtitle="Elecciones para Gobernador Guanajuato", caption="Método Geométrico") +
geom_text(aes(label=Frecuencia), nudge_x = 0.2)+ theme(axis.text.x = element_text(angle=45, vjust=0.6,size = 6))

El calculo de $n$ es

\[n=\frac{N\sum_{h=1}^{H}N_hS^2_h}{\frac{\delta^2}{z^2_{1-\alpha/2}}+\sum_{h=1}^{H}N_hS^2_h}\]

library(dplyr)
 Suma_NhSh2<- Gto2018 %>%
 group_by(ESTRATO_GEO)%>% summarise(NhS2=(var(LISTA_NOMINAL_2018))*n())
 
 #Se revisa el coeficiente de variación  en los estratos
Gto2018%>%
group_by(ESTRATO_GEO)%>% summarise(cv=sd(LISTA_NOMINAL_2018)/mean(LISTA_NOMINAL_2018))

#Tamaño de Muestra

n_G<-ceiling( {N*sum(Suma_NhSh2$NhS2)}/{(delta.precision/qnorm(0.95))^2+sum(Suma_NhSh2$NhS2)}
)

# Se hace la asignación proporcional por estratos
n_G*(table(Gto2018$ESTRATO_GEO)/sum(table(Gto2018$ESTRATO_GEO)))

## 
##   [100,353)  [353,1246) [1246,4398)  [4398,Inf] 
##    2.511005   46.636683   30.707496    2.144817

Nh_G<-FREC_GEO[,2] 
nh_G<-c(3,46,30,3)

# En los estratos más pequeños se incrementó el tamaño
# de muestra asignado

set.seed(10)

library(survey)

#Se seleciona la muestra aletoria por estratos
s<-stratsample(Gto2018$ESTRATO_GEO,
c("[100,353)"=3, "[353,1246)"=46,"[1246,4398)"=30, "[4398,Inf]"=3) )

Gto2018_SAMPLE_G<-
  Gto2018[s,]

# La verificación de balance de la muestra se hace calculando el estimador de la variable auxiliar.

xh_G <- Gto2018_SAMPLE_G %>% group_by(ESTRATO_GEO)%>% summarise(sum_xh=sum(LISTA_NOMINAL_2018) )

AUX_G<- cbind(Nh_G,nh_G,xh_G)

AUX2_G<-
AUX_G%>%
group_by(ESTRATO_GEO)%>% summarise(th=sum_xh/(nh_G/Nh_G))

hat.t_x_G<-sum(AUX2_G$th)

c_G<-abs(t_x-hat.t_x_G)/t_x
 # c_G=0.007037267 que es menor al 0.08 por lo tanto se
# considera que la muestra con estratificación geométrica # #esta balanceada.

yh_Sh2_G<- Gto2018_SAMPLE_G %>% group_by(ESTRATO_GEO)%>% summarise(sum_yh=sum(PRI),sh2=var(PRI) )

VOTO_PRI_G<- cbind(Nh_G,nh_G,yh_Sh2_G)

VOTO_PRI2_G<-
VOTO_PRI_G%>%
group_by(ESTRATO_GEO)%>% summarise(th=sum_yh/(nh_G/Nh_G),var_h=(Nh_G^2*(1-nh_G/Nh_G)*sh2/nh_G))

VOTO_PRI3_G<- cbind(VOTO_PRI_G,VOTO_PRI2_G[,-1])

t_st_G<-sum(VOTO_PRI3_G$th) 

LI_G<-t_st_G-qnorm(0.95)*sqrt(sum(VOTO_PRI3_G$var_h))

LS_G<-t_st_G+qnorm(0.95)*sqrt(sum(VOTO_PRI3_G$var_h)) 


#Precisión absoluta
PA_G<-abs(t_y-t_st_G)

#Precisión relativa
PR_G<-PA_G/t_y*100

El intervalo de confianza para el total de votos por PRI usando la estratificación geométrica y el muestreo estratificado se define por

$LI=$ 260704.4922595

$LS=$ 326949.6352767

que contiene al valor poblacional 291987. La precisión absoluta y relativa son 1840.0637681 y 0.6301869%, respectivamente.

El efecto de diseño se calcula como

\[deff=\frac{\widehat{Var}(\hat{t}_{st})}{\widehat{Var}(\hat{t}_{MAS})}\] Con un mismo tamaño de muestra $n$ se calcula la varianza de una muestra aleatoria de tamaño $n=82$

n<-82

pi_k<-(n/N)


var.hat.t_y_mas_G<-N^2*(1-n/N)*(var(Gto2018_SAMPLE_G$PRI)/n)

#El efecto de diseño es
var.hat.t_y_st_G<-sum(VOTO_PRI3_G$var_h)
deff<-var.hat.t_y_st_G/var.hat.t_y_mas_G

El efecto de diseño es 0.6382744 lo que indica que hay una ganancia en precisión por usar muestreo estratificado en lugar de muestreo aleatorio simple.

Para que este diseño tuviera la misma precisión que un muestreo aleatorio simple se tendría que reducir el tamaño de muestra, es decir, el tamaño de muestra para el muestreo estratificado se define como $n=n_{Estratificado}\times deff=82\times$ 0.6382744 $=$ 52.338498, la muestra final sería de tamaño 53.

Actividad II

Estratificación Daleniues-Hodges

library(tidyverse)
library(Hmisc)
library(knitr)

#Se planea tener 4 estratos al final
H<-4

#J determina el número inicial de grupos que generarán los estratos. 
J<-H*10


#La variable auxiliar es LISTA_NOMINAL 
# R_DH es la razón de la serie aritmética
#
R_DH<-(max(Gto2018$LISTA_NOMINAL_2018)-
  min(Gto2018$LISTA_NOMINAL_2018))/J

#CORTE indica los límites de los J grupos iniciales
CORTE<-
round(min(Gto2018$LISTA_NOMINAL_2018)+(R_DH*1:J),0)

#Las secciones se clasifican de acuerdo a los intervalos
#de tamaño de las secciones definidos por CORTE
Gto2018$GRUPO <- 
  cut2(Gto2018$LISTA_NOMINAL_2018, CORTE)

#===============================================
# Gráfica  de frecuencias que muestra la distribución
# de las secciones por tamaño de LISTA_NOMINAL
FREC<-as.data.frame(table(Gto2018$GRUPO))
names(FREC)<-c("Tamaño de las casillas", "Frecuencia")

library(ggplot2)
theme_set(theme_bw())

# Plot
ggplot(FREC, aes(x=`Tamaño de las casillas`, y=Frecuencia)) + 
  geom_point(size=3) + 
  geom_segment(aes(x=`Tamaño de las casillas`, 
                   xend=`Tamaño de las casillas`, 
                   y=0, 
                   yend=Frecuencia)) + 
  labs(title="Tamaño de listas nominales de las casillas", 
       subtitle="Elecciones para Gobernador Estado de Guanajuato", 
       caption="Agrupación Inicial") + 
  theme(axis.text.x = element_text(angle=65, vjust=0.6,size = 4))

FREC (frecuencias) corresponde a $f_i$ en la notación. $Q$ se calcula como \[Q=\frac{1}{H}\sum_{i=1}^J\sqrt{f_i}\]

Q<-table(Gto2018$GRUPO)%>%sqrt()%>%sum()/H

Los límites superiores de cada estrato de la variables LISTA_NOMINAL corresponden a la serie aritmética

\[Q,2Q,3Q,\ldots,(H-1)Q,HQ\]

1:H*Q

## [1]  47.52553  95.05106 142.57660 190.10213

#47.52553  95.05106 142.57660 190.10213

La siguiente tabla se usa para clasficar los $J=$40 grupos iniciales en los $H=$4 estratos, por ejemplo los grupos definidos por los intervalos de los grupos originales acumulan hasta 57.20364, el primer término de la sucesión aritmética es $Q=$190.1021279 , por los tanto el estrato 1 estará compuesto por las secciones cuya LISTA_NOMINAL sea menor a 871 personas.

Intervalos	$\sum\sqrt{f_i}$
[ 100, 486)	15.16575
[ 486, 871)	42.31349

table(Gto2018$GRUPO)%>%sqrt()%>%cumsum()

## [  100,  486) [  486,  871) [  871, 1257) [ 1257, 1642) [ 1642, 2028) 
##      15.16575      42.31349      72.87491      96.49693     112.49693 
## [ 2028, 2413) [ 2413, 2799) [ 2799, 3184) [ 3184, 3570) [ 3570, 3956) 
##     123.89869     132.38397     139.59507     145.59507     150.39090 
## [ 3956, 4341) [ 4341, 4727) [ 4727, 5112) [ 5112, 5498) [ 5498, 5883) 
##     155.08132     158.95430     162.95430     166.27093     169.09935 
## [ 5883, 6269)          6269 [ 6654, 7040) [ 7040, 7425) [ 7425, 7811) 
##     171.74510     171.74510     173.74510     175.15932     177.39539 
## [ 7811, 8197) [ 8197, 8582) [ 8582, 8968) [ 8968, 9353)          9353 
##     178.80960     180.54165     181.54165     183.27370     183.27370 
##          9739         10124 [10510,10895) [10895,11281)         11281 
##     183.27370     183.27370     184.27370     185.27370     185.27370 
##         11666         12052 [12438,12823) [12823,13209)         13209 
##     185.27370     185.27370     186.27370     187.68791     187.68791 
##         13594 [13980,14365)         14365         14751 [15136,15522] 
##     187.68791     188.68791     188.68791     188.68791     190.10213

#Todas las secciones se clasifican de acuerdo a la raíz de sus frecuencias acumuladas.
Gto2018$ESTRATO_DH<-cut(Gto2018$LISTA_NOMINAL_2018,
              c(100,871, 1257, 3184, Inf), include.lowest = TRUE, right = FALSE,dig.lab = 5)


#Tamaño de los estratos por secciones
table(Gto2018$ESTRATO_DH)

## 
##   [100,871)  [871,1257) [1257,3184)  [3184,Inf] 
##         967         934        1068         166

FREC_DH<-as.data.frame(table(Gto2018$ESTRATO_DH))
names(FREC_DH)<-c("Tamaño de los estratos", "Frecuencia")


# Plot
ggplot(FREC_DH, aes(x=`Tamaño de los estratos`, y=Frecuencia)) + 
  geom_point(size=1) + 
  geom_segment(aes(x=`Tamaño de los estratos`, 
                   xend=`Tamaño de los estratos`, 
                   y=0, 
                   yend=Frecuencia)) + 
  labs(title="Estratos de casillas", 
       subtitle="Elecciones para Gobernador Guanajuato", 
       caption="Método Dalenius-Hodges") + 
  geom_text(aes(label=Frecuencia), nudge_x = 0.2)+
  theme(axis.text.x = element_text(angle=45, vjust=0.6,size = 10))

Cálculo del tamaño de muestra, estratificación de Dalenius-Hodges

Los estratos están construidos con el método de Dalenius-Hodges, se quiere obtener un tamaño de muestra $n$ para estimar total de votos PRI, usando una asignación proporcional, con un nivel de confianza de $90\%$. La precisión se fija considerando el total de LISTA_NOMINAL_2018 para el Guanajuato en las elecciones para Gobernador en 2018.

La precisión se fija al $8\%$ Para este ejemplo la precisión $\delta\times Total(LISTA\_NOMINAL\_2018)=$ 345885.68 garantiza que la diferencia entre $t_y$ y $\hat{t}_y$ no será mayor al $8\%$.

El calculo de $n$ es

\[n=\frac{N\sum_{h=1}^{H}N_hS^2_h}{\frac{\delta^2}{z^2_{1-\alpha/2}}+\sum_{h=1}^{H}N_hS^2_h}\]

#Suma por estratos de la varianza de LISTA_NOMINAL
Suma_NhSh2<-  
Gto2018%>%
  group_by(ESTRATO_DH)%>%
  summarise(NhS2=(var(LISTA_NOMINAL_2018))*n())

#Se calcula el tamaño de muestra
   n<-ceiling(
     {N*sum(Suma_NhSh2$NhS2)}/{(delta.precision/qnorm(0.95))^2+sum(Suma_NhSh2$NhS2)}
   )
#Asignación proporcional por estratos  
n*(table(Gto2018$ESTRATO_DH)/sum(table(Gto2018$ESTRATO_DH)))

## 
##   [100,871)  [871,1257) [1257,3184)  [3184,Inf] 
##   24.984689   24.132057   27.594258    4.288995

#Tamaño de los estratos
Nh<-FREC_DH$Frecuencia

#Tamaño de muestra por estratos, asignación proporcional
nh<-c(25,24,27,5)
#Se asignó una unidad adicional de muestra al estrato con residual más grande y al estrato con menor tamaño de muestra

#Se utiliza el paquete survey para seleccionar la muestra dentro de cada estrato

library(survey)
set.seed(1)


s<-
  stratsample(Gto2018$ESTRATO_DH,
         c("[100,871)"=25,"[871,1257)"=24,"[1257,3184)"=27,"[3184,Inf]"=5))


#Se crea una base de datos solo con datos de la muestra de secciones

Gto2018_SAMPLE_DH<-Gto2018[s,]

Se calcula $\sum_{k=1}^{n_h}y_{kh}$ y $s^2_h$ por estrato, $y_{kh}$ es el total LISTA_NOMINAL_2018 para la sección $k$ en el estrato $H$.

xh_DH <- Gto2018_SAMPLE_DH %>% group_by(ESTRATO_DH)%>% summarise(sum_xh=sum(LISTA_NOMINAL_2018) )

AUX_DH<- cbind(Nh,nh,xh_DH)

AUX2_DH<-
AUX_DH%>%
group_by(ESTRATO_DH)%>% summarise(th=sum_xh/(nh/Nh))

hat.t_x_DH<-sum(AUX2_DH$th)

c_DH<-abs(t_x-hat.t_x_DH)/t_x

 # c_DH=0.009280697 que es menor al 0.08 por lo tanto se
# considera que la muestra con estratificación Dalenius-HODGES está balanceada.

yh_sh2<-  
  Gto2018_SAMPLE_DH%>%
  group_by(ESTRATO_DH)%>%
  summarise(sum_yh=sum(PRI),
            sh2=(var(PRI)))

VOTO_PRI_DH<-
  cbind(Nh,nh,yh_sh2)

Se calculan los totales estimados $\hat{t}_h$ por estrato de total votos PRI, también se calculan las estimaciones de varianzas por estrato $\widehat{Var}(\hat{t}_h)$.

VOTO_PRI2_DH<-
  VOTO_PRI_DH%>%
  group_by(ESTRATO_DH)%>%
  summarise(th=sum_yh/(nh/Nh),var_h=(Nh^2*(1-nh/Nh)*sh2/nh))

## `summarise()` ungrouping output (override with `.groups` argument)

VOTO_PRI3_DH<-
cbind(VOTO_PRI_DH,VOTO_PRI2_DH[,-1])

#Total estimado de total votos PRI usando una muestra estratificada y con estratos construidos
#con el método de Dalenius-Hodges y asignación proporcional.
t_st_DH<-sum(VOTO_PRI3_DH$th)

#Cota inferior intervalos de confianza
LI_DH<-t_st_DH-qnorm(0.95)*sqrt(sum(VOTO_PRI3_DH$var_h))

#Cota superior intervalos de confianza
LS_DH<-t_st_DH+qnorm(0.95)*sqrt(sum(VOTO_PRI3_DH$var_h))

#Precisión absoluta
PA_DH<-abs(t_y-t_st_DH)

#Precisión relativa
PR_DH<-PA_DH/t_y*100

El intervalo de confianza para el total de votos por PRI usando la estratificación Dalenius-Hodges y el muestreo estratificado se define por

$LI=$ 243280.0728624

$LS=$ 312770.2338042

que contiene al valor poblacional 291987. La precisión absoluta y relativa son 13961.8466667 y 4.7816672%, respectivamente.

El efecto de diseño se calcula como

\[deff=\frac{\widehat{Var}(\hat{t}_{st})}{\widehat{Var}(\hat{t}_{MAS})}\] Con un mismo tamaño de muestra $n$ se calcula la varianza de una muestra aleatoria de tamaño $n=81$

n<-81

pi_k<-(n/N)


var.hat.t_y_mas_DH<-N^2*(1-n/N)*(var(Gto2018_SAMPLE_DH$PRI)/n)

#El efecto de diseño es
var.hat.t_y_st_DH<-sum(VOTO_PRI3_DH$var_h)
deff_DH<-var.hat.t_y_st_DH/var.hat.t_y_mas_DH

El efecto de diseño es 0.6110232 lo que indica que hay una ganancia en precisión por usar muestreo estratificado en lugar de muestreo aleatorio simple.

Para que este diseño tuviera la misma precisión que un muestreo aleatorio simple se tendría que reducir el tamaño de muestra, es decir, el tamaño de muestra para el muestreo estratificado se define como $n=n_{Estr\_DH}\times deff=81\times$ 0.6110232 $=$ 49.492879, la muestra final sería de tamaño 50.

`Método`<-c("MAS","GEO","DH")
estimador<-c(hat.t_y, t_st_G, t_st_DH)
lim.inf<-c(LI, LI_G, LI_DH)
lim.sup<-c(LS, LS_G, LS_DH)
longitud<-lim.sup-lim.inf
data<-tibble(`Método`, estimador, lim.inf,lim.sup, longitud)


library(ggrepel)

## Warning: package 'ggrepel' was built under R version 3.6.2

ggplot(data, aes(x = `Método`, y = estimador, ymin = lim.inf, ymax = lim.sup, color=`Método`
)) +
  geom_pointrange()+
   geom_hline(yintercept=t_y,  
                color = "blue", size=0.3)+
  geom_label_repel(label=format(lim.sup-lim.inf,big.mark=",",scientific=FALSE, digits=5),size = 3, fill=c("blue","green",  "pink"),color="white")

kable(data)

Método	estimador	lim.inf	lim.sup	longitud
MAS	280855.8	258923.5	302788.1	43864.61
GEO	293827.1	260704.5	326949.6	66245.14
DH	278025.2	243280.1	312770.2	69490.16

Proyecto I

Actividad 1

Selección de una muestra con una precisión relativa de \(\pm8\%\) y una confiabilidad del \(90\%\)

Actividad II

Método Geométrico

Actividad II

Estratificación Daleniues-Hodges

Cálculo del tamaño de muestra, estratificación de Dalenius-Hodges