Sobre Implicit Association Tests (IAT) – Olhe o README do repositório.

IAT: 0.15, 0.35, and 0.65 are considered small, medium, and large levels of bias for individual scores. Positive means bias towards arts / against Math.

Exemplo de análise de uma replicação

iat = read_csv(here::here(params$arquivo_dados), col_types = "cccdc")
iat = iat %>% 
    mutate(sex = factor(sex, levels = c("m", "f"), ordered = TRUE))
glimpse(iat)
## Rows: 155
## Columns: 5
## $ session_id  <chr> "2436706", "2436967", "2440429", "2440430", "2440431", "24…
## $ referrer    <chr> "sdsu", "sdsu", "sdsu", "sdsu", "sdsu", "sdsu", "sdsu", "s…
## $ sex         <ord> f, f, f, f, m, f, f, m, f, m, f, f, f, f, f, f, m, m, f, m…
## $ d_art       <dbl> 0.90444320, -0.47402625, 0.46840862, -0.02522412, 0.136813…
## $ iat_exclude <chr> "Include", "Include", "Include", "Include", "Include", "In…
iat %>%
    ggplot(aes(x = d_art, fill = sex, color = sex)) +
    geom_histogram(binwidth = .2, alpha = .4) +
    geom_rug() +
    facet_grid(sex ~ ., scales = "free_y") + 
    theme(legend.position = "None")

iat %>% 
    ggplot(aes(x = sex, y = d_art)) + 
    geom_quasirandom(width = .1)

iat %>% 
    ggplot(aes(x = sex, y = d_art)) + 
    geom_quasirandom(width = .1) + 
    stat_summary(geom = "point", fun.y = "mean", color = "red", size = 5)
## Warning: The `fun.y` argument of `stat_summary()` is deprecated as of ggplot2 3.3.0.
## ℹ Please use the `fun` argument instead.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.

Qual a diferença na amostra
iat %>% 
    group_by(sex) %>% 
    summarise(media = mean(d_art))
## # A tibble: 2 × 2
##   sex   media
##   <ord> <dbl>
## 1 m     0.224
## 2 f     0.467
agrupado = iat %>% 
        group_by(sex) %>% 
        summarise(media = mean(d_art))
    m = agrupado %>% filter(sex == "m") %>% pull(media)
    f = agrupado %>% filter(sex == "f") %>% pull(media)
m - f
## [1] -0.2430539

Comparação via ICs

library(boot)

theta <- function(d, i) {
    agrupado = d %>% 
        slice(i) %>% 
        group_by(sex) %>% 
        summarise(media = mean(d_art))
    m = agrupado %>% filter(sex == "m") %>% pull(media)
    f = agrupado %>% filter(sex == "f") %>% pull(media)
    m - f
}

booted <- boot(data = iat, 
               statistic = theta, 
               R = 2000)

ci = tidy(booted, 
          conf.level = .95,
          conf.method = "bca",
          conf.int = TRUE)

glimpse(ci)
## Rows: 1
## Columns: 5
## $ statistic <dbl> -0.2430539
## $ bias      <dbl> 0.001731584
## $ std.error <dbl> 0.09085332
## $ conf.low  <dbl> -0.4204793
## $ conf.high <dbl> -0.06649807
ci %>%
    ggplot(aes(
        x = "",
        y = statistic,
        ymin = conf.low,
        ymax = conf.high
    )) +
    geom_pointrange() +
    geom_point(size = 3) + 
    labs(x = "Diferença", 
         y = "IAT homens - mulheres")

p1 = iat %>% 
    ggplot(aes(x = sex, y = d_art)) +
    geom_quasirandom(width = .1) + 
    stat_summary(geom = "point", fun.y = "mean", color = "red", size = 5)

p2 = ci %>%
    ggplot(aes(
        x = "",
        y = statistic,
        ymin = conf.low,
        ymax = conf.high
    )) +
    geom_pointrange() +
    geom_point(size = 3) + 
    ylim(-1, 1) + 
    labs(x = "Diferença", 
         y = "IAT homens - mulheres")

grid.arrange(p1, p2, ncol = 2)

desvio_padrao_e_n_por_sex <- iat %>%
  group_by(sex) %>%
  summarise(sd_d_art = sd(d_art, na.rm = TRUE), n = n())
# mulheres
desvio_padrao_f <- desvio_padrao_e_n_por_sex %>%
  filter(sex == "f") %>%
  pull(sd_d_art)

n_f <- desvio_padrao_e_n_por_sex %>%
  filter(sex == "f") %>%
  pull(n)

#homens
desvio_padrao_m <- desvio_padrao_e_n_por_sex %>%
  filter(sex == "m") %>%
  pull(sd_d_art)

n_m <- desvio_padrao_e_n_por_sex %>%
  filter(sex == "m") %>%
  pull(n)

Conclusão

Preencha os resultados e conclusões abaixo

Em média, as mulheres que participaram do experimento tiveram uma associação implícita (medida pelo IAT) com a matemática negativa e média (média: 0.4666898 , desv. padrão: 0.5475448, N: 117). Homens tiveram uma associação negativa com a matemática menor que a das mulheres (média: 0.2236359 , desv. padrão: 0.4850899, N: 38). Houve portanto uma considerável diferença entre homens e mulheres (diferença das médias -0.2430539, 95% CI [-0.4204793, -0.0664981]). A partir desta amostra, estimamos que:

* Mulheres possuem uma associação negativa pouco mais de 2x maior que a dos homens
* Ambos os gêneros possuem inclinação a arte, sendo esta, menor para os homens
* Apesar da amostra deixar visivel a diferença e inclinação entre os sexos quanto a arte e matemática, não é possível generalizar para todos pelos seguintes fatores: tamanho da amostra, falta de informações sobre localidade (talvez a cultura local possa influenciar no iat por ter maior presença de uma das áreas)
* A amostra possui mais dados relativos as mulheres do que aos homens, isso pode trazer mais precisão dos dados do grupo em si, porém a análise pode acabar sendo mais influenciada pelo mesmo, levando a um viés.
Realize novas análises sobre IAT usando as abordagens a seguir

Realize a análise e compare as conclusões obtidas nos dois casos experimentados:

1. bootstraps a partir de uma biblioteca (exemplo acima)

Utilizando o mesmo exemplo com nova base

Análise

iat_escolhido = read_csv(here::here(params$arquivo_dados_escolhido), col_types = "cccdc")
iat_escolhido = iat_escolhido %>% 
    mutate(sex = factor(sex, levels = c("m", "f"), ordered = TRUE))
glimpse(iat_escolhido)
## Rows: 167
## Columns: 5
## $ session_id  <chr> "2419031", "2419039", "2419118", "2419123", "2419126", "24…
## $ referrer    <chr> "jmu", "jmu", "jmu", "jmu", "jmu", "jmu", "jmu", "jmu", "j…
## $ sex         <ord> f, f, m, f, f, f, f, m, f, f, m, f, f, f, f, f, f, f, f, f…
## $ d_art       <dbl> 0.17962335, 0.67145001, 0.19227499, 1.25961243, 0.36845886…
## $ iat_exclude <chr> "Include", "Include", "Include", "Include", "Include", "In…
iat_escolhido %>%
    ggplot(aes(x = d_art, fill = sex, color = sex)) +
    geom_histogram(binwidth = .2, alpha = .4) +
    geom_rug() +
    facet_grid(sex ~ ., scales = "free_y") + 
    theme(legend.position = "None")

iat_escolhido %>% 
    ggplot(aes(x = sex, y = d_art)) + 
    geom_quasirandom(width = .1)

iat_escolhido %>% 
    ggplot(aes(x = sex, y = d_art)) + 
    geom_quasirandom(width = .1) + 
    stat_summary(geom = "point", fun.y = "mean", color = "red", size = 5)

Qual a diferença na amostra
iat_escolhido %>% 
    group_by(sex) %>% 
    summarise(media = mean(d_art))
## # A tibble: 2 × 2
##   sex   media
##   <ord> <dbl>
## 1 m     0.102
## 2 f     0.515
agrupado_escolhido = iat_escolhido %>% 
        group_by(sex) %>% 
        summarise(media = mean(d_art))
    m_escolhido = agrupado_escolhido %>% filter(sex == "m") %>% pull(media)
    f_escolhido = agrupado_escolhido %>% filter(sex == "f") %>% pull(media)
m_escolhido - f_escolhido
## [1] -0.4132179

Comparação via ICs

library(boot)

theta_escolhido <- function(d, i) {
    agrupado_escolhido = d %>% 
        slice(i) %>% 
        group_by(sex) %>% 
        summarise(media = mean(d_art))
    m_escolhido = agrupado_escolhido %>% filter(sex == "m") %>% pull(media)
    f_escolhido = agrupado_escolhido %>% filter(sex == "f") %>% pull(media)
    m_escolhido - f_escolhido
}

booted_escolhido <- boot(data = iat_escolhido, 
               statistic = theta_escolhido, 
               R = 2000)

ci_escolhido = tidy(booted_escolhido, 
          conf.level = .95,
          conf.method = "bca",
          conf.int = TRUE)

glimpse(ci_escolhido)
## Rows: 1
## Columns: 5
## $ statistic <dbl> -0.4132179
## $ bias      <dbl> 0.001664502
## $ std.error <dbl> 0.1093531
## $ conf.low  <dbl> -0.6097097
## $ conf.high <dbl> -0.1706983
ci_escolhido %>%
    ggplot(aes(
        x = "",
        y = statistic,
        ymin = conf.low,
        ymax = conf.high
    )) +
    geom_pointrange() +
    geom_point(size = 3) + 
    labs(x = "Diferença", 
         y = "IAT homens - mulheres")

p1_escolhido = iat_escolhido %>% 
    ggplot(aes(x = sex, y = d_art)) +
    geom_quasirandom(width = .1) + 
    stat_summary(geom = "point", fun.y = "mean", color = "red", size = 5)

p2_escolhido = ci_escolhido %>%
    ggplot(aes(
        x = "",
        y = statistic,
        ymin = conf.low,
        ymax = conf.high
    )) +
    geom_pointrange() +
    geom_point(size = 3) + 
    ylim(-1, 1) + 
    labs(x = "Diferença", 
         y = "IAT homens - mulheres")

grid.arrange(p1, p2, ncol = 2)

desvio_padrao_e_n_por_sex_escolhido <- iat %>%
  group_by(sex) %>%
  summarise(sd_d_art = sd(d_art, na.rm = TRUE), n = n())
# mulheres
desvio_padrao_f_escolhido <- desvio_padrao_e_n_por_sex_escolhido %>%
  filter(sex == "f") %>%
  pull(sd_d_art)

n_f_escolhido <- desvio_padrao_e_n_por_sex_escolhido %>%
  filter(sex == "f") %>%
  pull(n)

#homens
desvio_padrao_m_escolhido <- desvio_padrao_e_n_por_sex_escolhido %>%
  filter(sex == "m") %>%
  pull(sd_d_art)

n_m_escolhido <- desvio_padrao_e_n_por_sex_escolhido %>%
  filter(sex == "m") %>%
  pull(n)

Conclusão

Preencha os resultados e conclusões abaixo

Em média, as mulheres que participaram do experimento tiveram uma associação implícita (medida pelo IAT) com a matemática negativa e média (média: 0.5148934 , desv. padrão: 0.5475448, N: 117). Homens tiveram uma associação negativa com a matemática menor que a das mulheres (média: 0.1016755 , desv. padrão: 0.4850899, N: 38). Houve portanto uma considerável diferença entre homens e mulheres (diferença das médias -0.4132179, 95% CI [-0.6097097, -0.1706983]). A partir desta amostra, estimamos que:

* Mulheres possuem uma associação negativa pouco mais de 4x maior que a dos homens
* O nível IAT dos homens é bem pequeno com relação a arte
* Ambos os gêneros possuem inclinação a arte, sendo esta, muito menor para os homens
* Mesmo que os dados indiquem que o nível de IAT dos homens é baixo com inclinação a arte, há necessidade de que sejam coletados mais dados deste grupo, pois há uma diferença consideravel entre ambos grupos
* Apesar da amostra deixar visivel a diferença e inclinação entre os sexos quanto a arte e matemática, não é possível generalizar para todos pelos seguintes fatores: dados categóricos desproporcionais, falta de informações sobre localidade (talvez a cultura local possa influenciar no iat por ter maior presença de uma das áreas)

2. bootstraps implementados por você (justifique o método de IC com bootstraps escolhido)

Devido ao fato da quantidade de dados do grupo dos homens ser bem menor, foi selecionado o weighted bootstrap para aumentar o peso da influência deste grupo e realizar o calculo do IC

iat_escolhido$peso <- ifelse(iat_escolhido$sex == 'm', 2, 1)

calcular_diferenca_medias <- function(data) {
  media_m <- weighted.mean(data$d_art[data$sex == 'm'], data$peso[data$sex == 'm'])
  media_f <- weighted.mean(data$d_art[data$sex == 'f'], data$peso[data$sex == 'f'])
  return(media_m - media_f)
}

repeticoes <- 2000
bootstrap_medias <- numeric(repeticoes)

set.seed(325)
for (i in 1:repeticoes) {
  amostra_indices <- sample(1:nrow(iat_escolhido), nrow(iat_escolhido), replace = TRUE, prob = iat_escolhido$peso)
  amostra_bootstrap <- iat_escolhido[amostra_indices, ]
  bootstrap_medias[i] <- calcular_diferenca_medias(amostra_bootstrap)
}

alpha <- 0.05
lower_bound <- quantile(bootstrap_medias, alpha / 2)
upper_bound <- quantile(bootstrap_medias, 1 - alpha / 2)

# Resultados
resultados <- list(
  statistic = mean(bootstrap_medias),
  bias = mean(bootstrap_medias) - calcular_diferenca_medias(iat_escolhido),
  std_error = sd(bootstrap_medias),
  conf_low = lower_bound,
  conf_high = upper_bound
)

print(resultados)
## $statistic
## [1] -0.4141769
## 
## $bias
## [1] -0.0009589864
## 
## $std_error
## [1] 0.08658666
## 
## $conf_low
##       2.5% 
## -0.5773004 
## 
## $conf_high
##      97.5% 
## -0.2408421

A partir deste cálculo é possível perceber que houve uma diminuição no intervalo de confiança, deixando-o mais próximo do valor da estatística avaliada. Sendo assim, essa estratégia parece ter sido um pouco melhor, diminuindo o erro gerado pela diferença de quantidade de dados do grupo masculino e também trazendo um bias negativo, o que indica que a tecnica de boostrap utilizada está sendo efetiva para trazer estimativas mais precisas.Para isso, podemos comparar os ICs: BCA = 95% CI [-0.6097097, -0.1706983] WB = 95% CI [-0.5773004, -0.2408421]

bootstrap_df <- data.frame(bootstrap_statistic = bootstrap_medias)

hist1 = ggplot(bootstrap_df, aes(x = bootstrap_statistic)) +
  geom_histogram(binwidth = 0.02, fill = "grey", color = "black", alpha = 0.7) +
  labs(title = "Histograma das médias com Weighted Bootstrap",
       x = "Diferença nas Médias Ponderadas",
       y = "Frequência") +ylim(0, 200)+
  theme_minimal()+
  theme(
    plot.title = element_text(size = 10) 
  )



bootstrap_df_escolhido <- data.frame(bootstrap_statistic = booted_escolhido$t)

hist2 = ggplot(bootstrap_df_escolhido, aes(x = bootstrap_statistic)) +
  geom_histogram(binwidth = 0.02, fill = "grey", color = "black", alpha = 0.7) +
  labs(title = "Histograma das médias com o método BCA",
       x = "Diferença nas Médias com bootstrap do método",
       y = "Frequência") + ylim(0, 200) + 
  theme_minimal()+
  theme(
    plot.title = element_text(size = 10) 
  )


grid.arrange(hist1, hist2, ncol = 2)

Observando ambos os gráficos é perceptível o quanto a utilização do weighted bootstrap trouxe a distribuição para mais próxima da normal (mesmo que a original já estivesse bem próxima). Com o método BCA o pico do histograma é muito mais largo, enquanto com a técnica escolhida, houve um maior afunilamento. Sendo assim, dado as estatísticas apresentadas, a técnica escolhida forneceu maior precisão em comparação com o BCA para a amostra escolhida.