Análises sobre um experimento com sorrisos e o tempo de carregamento de portais

Informações

Aluno: Thiago Yuri Evaristo de Souza

Matrícula: 117211156

Um experimento com sorrisos

Para iniciar a analise carregamos o arquivo data/leniency.csv e visualizamos como são nossos dados:

leniency = read_csv(here::here("data/leniency.csv"), 
                 col_types = "cdc")

glimpse(leniency)

## Rows: 136
## Columns: 3
## $ smile      <chr> "false smile", "false smile", "false smile", "false smile",…
## $ leniency   <dbl> 2.5, 5.5, 6.5, 3.5, 3.0, 3.5, 6.0, 5.0, 4.0, 4.5, 5.0, 5.5,…
## $ with_smile <chr> "yes", "yes", "yes", "yes", "yes", "yes", "yes", "yes", "ye…

Observamos abaixo algumas informações sobre os dados de cada coluna, não há dados faltantes. O valor mínimo e máximo para coluna leniency (índice feito de respostas para 5 perguntas em uma escala de 0 a 9) é de 2 e 9, não houve valor entre 0 a 2.

summary(leniency)

##     smile              leniency      with_smile       
##  Length:136         Min.   :2.000   Length:136        
##  Class :character   1st Qu.:3.500   Class :character  
##  Mode  :character   Median :4.500   Mode  :character  
##                     Mean   :4.827                     
##                     3rd Qu.:6.000                     
##                     Max.   :9.000

Abaixamos vemos o comportamento do índice leniency de acordo as colunas with_smile e smile, observamos que há 4 categorias para coluna smile, “false smile”, “felt smile”, “miserable smile” e “no smile (control)”, cada uma com 34 amostras. Já para coluna with_smile há 2 categorias, yes ou no, em que “no” é o caso de “no smile (control)” na coluna smile. Observamos tambem que:

Para with_smile:

• “yes” temos um valor maximo maior que 8 e valor minimo igual a 2.5
• “no” temos um valor máximo de 8 e valores minimos menores que 2.5

Para smile:

• “no smile (control)” temos um valor extremo maximo de 8 e minimo de 2 (mesmo caso para o “no” da coluna with_smile)
• “miserable smile” temos um valor minimo de 2.5 e maximo de 8
• “felt smile” temos um valor minimo de 2.5 e maximo de 9
• “false smile” temos um valor minimo de 2.5 e maximo de 9 (mesmo caso do “felt smile”, mas vemos leves mudanças mais abaixo)

leniency %>%
  ggplot(aes(x=leniency, y=with_smile)) +
  geom_jitter(height = .2, width = 0, alpha = .5, color = "coral") +
  labs(
    title = "Gráfico de dispersão dos valores de leniency versus with_smile",
    y = "with smile"
  )

leniency %>%
  group_by(with_smile) %>%
  count()

leniency %>%
  ggplot(aes(x=leniency, y=smile)) +
  geom_jitter(height = .2, width = 0, alpha = 0.5, color = "coral") +
  labs(
    title = "Gráfico de dispersão dos valores de leniency\nversus smile",
    y = "smile"
  )

leniency %>%
  group_by(smile) %>%
  count()

Analisando novamente os valores para o smile temos:

• “no smile (control)” temos uma maior concentração dos valores proximos a 3-4 (um pouco a baixo de 3)
• “miserable smile” possui uma concentração em valores em 4 e 5
• “felt smile” possui uma concentração em valores um pouco maior que 3 ate proximo a 5
• “false smile” possui duas modas, uma em 3 e outra em 6

Agora vejamos nossas pesquisas …

leniency %>%
  ggplot(aes(x=leniency, y=smile, fill = ..x..)) +
  geom_density_ridges_gradient(scale = 1, rel_min_height = 0.01) +
  scale_fill_viridis(name = "Leniency", option = "C") +
  labs(
    title = "Gráfico de densidade dos valores de leniency\nversus smile",
    y = "smile",
    x = ""
  )

## Picking joint bandwidth of 0.67

1. Quanto ter a pessoa sorrindo na foto (independente do sorriso) causa de mudança no julgamento das pessoas em geral? Quão relevante é essa mudança?

Observemos então como a média da leniency das amostras com sorriso (with_smile = “yes”) menos a média da leniency das amostras sem sorriso (with_smile = “no”). Fazendo boostrap para reamostragem dos dados temos com uma confiança de 95% em que a diferença esperada entre with_smile = yes e with_smile = no é de 0.94 IC [0.32, 1.55]. A uma diferença entre os casos pode ser considerada relevante (> que 0.5) ou representativa (0.3 < diff < 0.5).

s <- function(d, i) {
    a = d[i,] %>% 
      filter(with_smile == "yes") %>%
      summarise(mean_leniency_with_smile_yes = mean(leniency)) %>% 
      pull(mean_leniency_with_smile_yes)
    
    b = d[i,] %>% 
      filter(with_smile == "no") %>%
      summarise(mean_leniency_with_smile_no = mean(leniency)) %>% 
      pull(mean_leniency_with_smile_no)
    
    a - b
}

booted <- boot(data = leniency,
               statistic = s, 
               R = 2000)

estimado = tidy(booted, 
                conf.level = .95,
                conf.method = "basic",
                conf.int = TRUE)

glimpse(estimado)

## Rows: 1
## Columns: 5
## $ statistic <dbl> 0.9460784
## $ bias      <dbl> -0.002906364
## $ std.error <dbl> 0.3103976
## $ conf.low  <dbl> 0.3245577
## $ conf.high <dbl> 1.556836

estimado %>% 
    ggplot(aes(
        ymin = conf.low,
        y = statistic,
        ymax = conf.high,
        x = "Leniência"
    )) +
    geom_linerange() +
    geom_point(color = "steelblue", size = 2) +
    geom_text(
        aes(
            y = conf.high,
            label = str_glue("[{round(conf.low, 2)}, {round(conf.high, 2)}]")
        ),
        size = 3,
        nudge_x = -.05,
        show.legend = F
    )  +
    scale_y_continuous(limits = c(0, 2)) +
    labs(
        title = "Diferença entre média do índice de\nleniência com sorriso e sem sorriso",
        x = "", y = "") +
    coord_flip()

Agora verificando por meio de testes de hipóteses temos:

theta_chapeu_1_1 = 0.9460784

s <- function(d){
  embaralhados = d %>% mutate(k_unit_sum = sample(leniency, size = n()))
  
   a = embaralhados %>% 
      filter(with_smile == "yes") %>%
      summarise(mean_leniency_with_smile_yes = mean(k_unit_sum)) %>% 
      pull(mean_leniency_with_smile_yes)
    
    b = embaralhados %>% 
      filter(with_smile == "no") %>%
      summarise(mean_leniency_with_smile_no = mean(k_unit_sum)) %>% 
      pull(mean_leniency_with_smile_no)
    
    a - b
}

simulacoes_1_1 = tibble(simulacao = 1:5000) %>%
  mutate(theta_nulo = map_dbl(simulacao, ~s(leniency)))

simulacoes_1_1 %>%
  ggplot(aes(x = theta_nulo)) +
  geom_histogram(binwidth = .05, fill = "coral") +
  geom_rug() +
  geom_vline(xintercept = c(-theta_chapeu_1_1, theta_chapeu_1_1)) +
  geom_text(aes(x=-theta_chapeu_1_1, label="\ntheta_chapeu", y=200), colour="black", angle=90) +
  geom_text(aes(x=theta_chapeu_1_1, label="\ntheta_chapeu", y=200), colour="black", angle=90) +
  labs(
    title = "Histograma das simulações para theta nulo\ncom interceptos de theta chapeu para\nleniência com sorriso e sem sorriso",
    subtitle = "theta_chapeu = 0.9460784"
  )

p = simulacoes_1_1 %>%
  summarise(p_valor = sum(abs(theta_nulo) >= abs(theta_chapeu_1_1)) / n(),
            .groups = "drop")

p

No teste de hipótese podemos dizer se há ou não mudança do julgamento das pessoas em geral, pois esse método não há como medir quanto e se é relevante. Mas pelos resultados acima podemos ver que o p_valor é bem proximo a 0, o que indica que há indicios de rejeitar a hipotese nula (não se comporta como as simulações de theta_nulo), indicando que há uma mudança no julgamento. Obs.: É analisado a diferença das médias das leniências para amostras com sorriso (cs) e sem sorriso (ss), ou seja, cs - ss.

2. Como se comparam os efeitos dos diferentes sorrisos no julgamento das pessoas?

Observamos que:

• miserable smile - no smile com o resultado do bootstrap (95% de confiança), temos um intervalo de [0.09, 1.5] o que é considerado uma diferença pouco ou irrevalente (próximo a 0), mas também pode ser muito relevante (proximo a 1.5)
• felt smile - no smile com o resultado do bootstrap (95% de confiança), temos um intervalo de [-0.007, 1.5] o que é também considerado uma diferença pouco ou irrevalente (próximo a 0), mas também pode ser muito relevante (proximo a 1.5)
• false smile - no smile com o resultado do bootstrap (95% de confiança), temos um intervalo de [0.41, 2.04] o que é considerado uma diferença relevante (proximo a 0.5) ou muito relevante (proximo a 1.5)

s_miserable <- function(d, i) {
    a = d[i,] %>% 
      filter(smile == "miserable smile") %>%
      summarise(miserable_smile_leniency = mean(leniency)) %>% 
      pull(miserable_smile_leniency)
    
    b = d[i,] %>% 
      filter(smile == "no smile (control)") %>%
      summarise(no_smile_control_leniency = mean(leniency)) %>% 
      pull(no_smile_control_leniency)
    
    a - b
}

booted <- boot(data = leniency, 
               statistic = s_miserable, 
               R = 2000)

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

glimpse(estimado_miserable)

## Rows: 1
## Columns: 5
## $ statistic <dbl> 0.7941176
## $ bias      <dbl> 0.01157734
## $ std.error <dbl> 0.3647162
## $ conf.low  <dbl> 0.009675661
## $ conf.high <dbl> 1.507644

s_felt <- function(d, i) {
    a = d[i,] %>% 
      filter(smile == "felt smile") %>%
      summarise(felt_smile_leniency = mean(leniency)) %>% 
      pull(felt_smile_leniency)
    
    b = d[i,] %>% 
      filter(smile == "no smile (control)") %>%
      summarise(no_smile_control_leniency = mean(leniency)) %>% 
      pull(no_smile_control_leniency)
    
    a - b
}

booted <- boot(data = leniency, 
               statistic = s_felt, 
               R = 2000)

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

glimpse(estimado_felt)

## Rows: 1
## Columns: 5
## $ statistic <dbl> 0.7941176
## $ bias      <dbl> 0.002793048
## $ std.error <dbl> 0.3799197
## $ conf.low  <dbl> 0.04128421
## $ conf.high <dbl> 1.526302

s_false <- function(d, i) {
    a = d[i,] %>% 
      filter(smile == "false smile") %>%
      summarise(false_smile_leniency = mean(leniency)) %>% 
      pull(false_smile_leniency)
    
    b = d[i,] %>%
      filter(smile == "no smile (control)") %>%
      summarise(no_smile_control_leniency = mean(leniency)) %>% 
      pull(no_smile_control_leniency)
    
    a - b
}

booted <- boot(data = leniency, 
               statistic = s_false, 
               R = 2000)

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

glimpse(estimado_false)

## Rows: 1
## Columns: 5
## $ statistic <dbl> 1.25
## $ bias      <dbl> 0.01468077
## $ std.error <dbl> 0.4068686
## $ conf.low  <dbl> 0.4515213
## $ conf.high <dbl> 2.045196

estimado_miserable %>% 
    ggplot(aes(
        ymin = conf.low,
        y = statistic,
        ymax = conf.high,
        x = "ms - ns"
    )) +
    geom_linerange() +
    geom_point(color = "steelblue", size = 2) +
    geom_text(
        aes(
            y = conf.high,
            label = str_glue("[{round(conf.low, 2)}, {round(conf.high, 2)}]")
        ),
        size = 3,
        nudge_x = -.05,
        show.legend = F
    )  +
    scale_y_continuous(limits = c(-0.5, 2.5)) +
    labs(
        title = "Diferença entre intervalo estimado para leniência",
        subtitle = str_glue("misarable smile (ms) - no smile (ns)"),
        x = "", y = "") +
    coord_flip()

Agora verificando por meio de testes de hipóteses temos:

theta_chapeu_1_2_1 = 0.7941176

s <- function(d){
  embaralhados = d %>% mutate(k_unit_sum = sample(leniency, size = n()))
  
    a = embaralhados %>% 
      filter(smile == "miserable smile") %>%
      summarise(false_smile_leniency = mean(k_unit_sum)) %>% 
      pull(false_smile_leniency)
    
    b = embaralhados %>%
      filter(smile == "no smile (control)") %>%
      summarise(no_smile_control_leniency = mean(k_unit_sum)) %>% 
      pull(no_smile_control_leniency)
    
    a - b
}

simulacoes_1_2_1 = tibble(simulacao = 1:5000) %>%
  mutate(theta_nulo = map_dbl(simulacao, ~s(leniency)))

simulacoes_1_2_1 %>%
  ggplot(aes(x = theta_nulo)) +
  geom_histogram(binwidth = .05, fill = "coral") +
  geom_rug() +
  geom_vline(xintercept = c(-theta_chapeu_1_2_1, theta_chapeu_1_2_1)) +
  geom_text(aes(x=-theta_chapeu_1_2_1, label="\ntheta_chapeu", y=200), colour="black", angle=90) +
  geom_text(aes(x=theta_chapeu_1_2_1, label="\ntheta_chapeu", y=200), colour="black", angle=90) +
  labs(
    title = "Histograma das simulações para theta nulo\ncom interceptos de theta chapeu para\nleniência com miresable smile e no smile",
    subtitle = "theta_chapeu = 0.7941176"
  )

p = simulacoes_1_2_1 %>%
  summarise(p_valor = sum(abs(theta_nulo) >= abs(theta_chapeu_1_2_1)) / n(),
            .groups = "drop")

p

No teste de hipótese podemos dizer se há ou não mudança do julgamento das pessoas em geral, pois esse método não há como medir quanto e se é relevante. Mas pelos resultados acima podemos ver que o p_valor é bem proximo a 0, o que indica que há indicios de rejeitar a hipotese nula (não se comporta como as simulações de theta_nulo), indicando que há uma mudança no julgamento.

estimado_felt %>% 
    ggplot(aes(
        ymin = conf.low,
        y = statistic,
        ymax = conf.high,
        x = "fs - ns"
    )) +
    geom_linerange() +
    geom_point(color = "steelblue", size = 2) +
    geom_text(
        aes(
            y = conf.high,
            label = str_glue("[{round(conf.low, 2)}, {round(conf.high, 2)}]")
        ),
        size = 3,
        nudge_x = -.05,
        show.legend = F
    )  +
    scale_y_continuous(limits = c(-0.5, 2.5)) +
    labs(
        title = "Diferença entre intervalo estimado para leniência",
        subtitle = str_glue("felt smile (fs) - no smile (ns)"),
        x = "", y = "") +
    coord_flip()

Agora verificando por meio de testes de hipóteses temos:

theta_chapeu_1_2_2 = 0.7941176

s <- function(d){
  embaralhados = d %>% mutate(k_unit_sum = sample(leniency, size = n()))
  
    a = embaralhados %>% 
      filter(smile == "felt smile") %>%
      summarise(false_smile_leniency = mean(k_unit_sum)) %>% 
      pull(false_smile_leniency)
    
    b = embaralhados %>%
      filter(smile == "no smile (control)") %>%
      summarise(no_smile_control_leniency = mean(k_unit_sum)) %>% 
      pull(no_smile_control_leniency)
    
    a - b
}

simulacoes_1_2_2 = tibble(simulacao = 1:5000) %>%
  mutate(theta_nulo = map_dbl(simulacao, ~s(leniency)))

simulacoes_1_2_2 %>%
  ggplot(aes(x = theta_nulo)) +
  geom_histogram(binwidth = .05, fill = "coral") +
  geom_rug() +
  geom_vline(xintercept = c(-theta_chapeu_1_2_2, theta_chapeu_1_2_2)) +
  geom_text(aes(x=-theta_chapeu_1_2_2, label="\ntheta_chapeu", y=200), colour="black", angle=90) +
  geom_text(aes(x=theta_chapeu_1_2_2, label="\ntheta_chapeu", y=200), colour="black", angle=90) +
  labs(
    title = "Histograma das simulações para theta nulo\ncom interceptos de theta chapeu para\nleniência com felt smile e no smile",
    subtitle = "theta_chapeu = 0.7941176"
  )

p = simulacoes_1_2_2 %>%
  summarise(p_valor = sum(abs(theta_nulo) >= abs(theta_chapeu_1_2_2)) / n(),
            .groups = "drop")

p

No teste de hipótese podemos dizer se há ou não mudança do julgamento das pessoas em geral, pois esse método não há como medir quanto e se é relevante. Mas pelos resultados acima podemos ver que o p_valor é bem proximo a 0, o que indica que há indicios de rejeitar a hipotese nula (não se comporta como as simulações de theta_nulo), indicando que há uma mudança no julgamento.

estimado_false %>% 
    ggplot(aes(
        ymin = conf.low,
        y = statistic,
        ymax = conf.high,
        x = "fls - ns"
    )) +
    geom_linerange() +
    geom_point(color = "steelblue", size = 2) +
    geom_text(
        aes(
            y = conf.high,
            label = str_glue("[{round(conf.low, 2)}, {round(conf.high, 2)}]")
        ),
        size = 3,
        nudge_x = -.05,
        show.legend = F
    )  +
    scale_y_continuous(limits = c(-0.5, 2.5)) +
    labs(
        title = "Diferença entre intervalo estimado para leniência",
        subtitle = str_glue("false smile (fls) - no smile (ns)"),
        x = "", y = "") +
    coord_flip()

Agora verificando por meio de testes de hipóteses temos:

theta_chapeu_1_2_3 = 1.25

s <- function(d){
  embaralhados = d %>% mutate(k_unit_sum = sample(leniency, size = n()))
  
    a = embaralhados %>% 
      filter(smile == "false smile") %>%
      summarise(false_smile_leniency = mean(k_unit_sum)) %>% 
      pull(false_smile_leniency)
    
    b = embaralhados %>%
      filter(smile == "no smile (control)") %>%
      summarise(no_smile_control_leniency = mean(k_unit_sum)) %>% 
      pull(no_smile_control_leniency)
    
    a - b
}

simulacoes_1_2_3 = tibble(simulacao = 1:5000) %>%
  mutate(theta_nulo = map_dbl(simulacao, ~s(leniency)))

simulacoes_1_2_3 %>%
  ggplot(aes(x = theta_nulo)) +
  geom_histogram(binwidth = .05, fill = "coral") +
  geom_rug() +
  geom_vline(xintercept = c(-theta_chapeu_1_2_3, theta_chapeu_1_2_3)) +
  geom_text(aes(x=-theta_chapeu_1_2_3, label="\ntheta_chapeu", y=200), colour="black", angle=90) +
  geom_text(aes(x=theta_chapeu_1_2_3, label="\ntheta_chapeu", y=200), colour="black", angle=90) +
  labs(
    title = "Histograma das simulações para theta nulo\ncom interceptos de theta chapeu para\nleniência com false smile e no smile",
    subtitle = "theta_chapeu = 1.25"
  )

p = simulacoes_1_2_3 %>%
  summarise(p_valor = sum(abs(theta_nulo) >= abs(theta_chapeu_1_2_3)) / n(),
            .groups = "drop")

p

No teste de hipótese podemos dizer se há ou não mudança do julgamento das pessoas em geral, pois esse método não há como medir quanto e se é relevante. Mas pelos resultados acima podemos ver que o p_valor é bem proximo a 0, o que indica que há indicios de rejeitar a hipotese nula (não se comporta como as simulações de theta_nulo), indicando que há uma mudança no julgamento.

Tempo de carregamento de portais

Para iniciar esta proxima analise carregamos o arquivo data/requests-portais.csv e visualizamos como são nossos dados:

requests_portais = read_csv(here::here("data/requests-portais.csv"), 
                 col_types = "cd")

glimpse(requests_portais)

## Rows: 120
## Columns: 2
## $ site <chr> "g1", "g1", "g1", "g1", "g1", "g1", "g1", "g1", "g1", "g1", "g1",…
## $ time <dbl> 1.600459, 1.471800, 1.398192, 1.380360, 1.386828, 1.529101, 1.393…

Observamos abaixo algumas informações sobre os dados de cada coluna, não há dados faltantes. O valor mínimo e máximo para coluna time (tempo de resposta em segundos de cada requisição) é de 0.3422 e 1.6824.

summary(requests_portais)

##      site                time       
##  Length:120         Min.   :0.3422  
##  Class :character   1st Qu.:0.3616  
##  Mode  :character   Median :0.5872  
##                     Mean   :0.7127  
##                     3rd Qu.:1.0004  
##                     Max.   :1.6824

Abaixamos vemos o comportamento do tempo de acordo a coluna site, observamos que há 4 tipos de site, “uol”, “terra”, “g1” e “folha”, cada uma com 30 amostras. Observamos tambem que:

Para site:

• “uol” e “folha” temos os menores tempos de requisição (mais rápidos), havendo uma leve diferença ou quase nula
• “terra” e “g1” temos os maiores tempos de requisição (mais lentos), havendo uma diferença clara entre os tempos dos sites.

requests_portais %>%
  ggplot(aes(x=time, y=site)) +
  geom_jitter(height = .2, width = 0, alpha = .5, color = "coral") +
  labs(
    title = "Gráfico de dispersão dos tempos para\nrequisições versus site",
    y = "site",
    x = "tempo em segundos"
  )

requests_portais %>%
  group_by(site) %>%
  count()

Agora vejamos nossas pesquisas …

1. Considerando a média de tempo para responder, qual você estima que é o portal mais rápido em geral (ou seja, na população de todas as requisições que originou nossa amostra)?

Observa-se que os sites folha e uol possuem os melhores tempos (mais rapidos = menos segundos) de requisições. Podemos ver que a média do uol é de 0.3556272 e a do folha é de 0.3791591, o que é ligeramente maior. Se observamos o seu intervalo de confiança (com 95%) não há uma intersecção de valores, mas é algo bem próximo. Na próxima verificamos melhor a diferença entre eles.

s_uol <- function(d, i) {
    d[i,] %>% 
      filter(site == "uol") %>%
      summarise(mean_time = mean(time)) %>%
      pull(mean_time)
}

booted <- boot(data = requests_portais, 
               statistic = s_uol,
               R = 2000)

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

glimpse(estimado_times_uol)

## Rows: 1
## Columns: 5
## $ statistic <dbl> 0.3556272
## $ bias      <dbl> -5.174587e-06
## $ std.error <dbl> 0.003670683
## $ conf.low  <dbl> 0.3512712
## $ conf.high <dbl> 0.3692145

s_terra <- function(d, i) {
    d[i,] %>% 
      filter(site == "terra") %>%
      summarise(mean_time = mean(time)) %>%
      pull(mean_time)
}

booted <- boot(data = requests_portais, 
               statistic = s_terra, 
               R = 2000)

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

glimpse(estimado_times_terra)

## Rows: 1
## Columns: 5
## $ statistic <dbl> 0.6723314
## $ bias      <dbl> 0.0001475533
## $ std.error <dbl> 0.009381396
## $ conf.low  <dbl> 0.6587438
## $ conf.high <dbl> 0.6990163

s_folha <- function(d, i) {
    d[i,] %>% 
      filter(site == "folha") %>%
      summarise(mean_time = mean(time)) %>%
      pull(mean_time)
}

booted <- boot(data = requests_portais, 
               statistic = s_folha, 
               R = 2000)

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

glimpse(estimado_times_folha)

## Rows: 1
## Columns: 5
## $ statistic <dbl> 0.3791591
## $ bias      <dbl> 5.484223e-05
## $ std.error <dbl> 0.0062718
## $ conf.low  <dbl> 0.371437
## $ conf.high <dbl> 0.4035246

s_g1 <- function(d, i) {
    d[i,] %>% 
      filter(site == "g1") %>%
      summarise(mean_time = mean(time)) %>%
      pull(mean_time)
}

booted <- boot(data = requests_portais, 
               statistic = s_g1, 
               R = 2000)

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

glimpse(estimado_times_g1)

## Rows: 1
## Columns: 5
## $ statistic <dbl> 1.443589
## $ bias      <dbl> 1.940684e-05
## $ std.error <dbl> 0.01391627
## $ conf.low  <dbl> 1.421719
## $ conf.high <dbl> 1.479612

estimado_times_folha = estimado_times_folha %>%
  mutate(site = "folha")

estimado_times_uol = estimado_times_uol %>%
  mutate(site = "uol")

estimado_times_g1 = estimado_times_g1 %>%
  mutate(site = "g1")

estimado_times_terra = estimado_times_terra %>%
  mutate(site = "terra")

a = merge(estimado_times_folha, estimado_times_uol, all = TRUE)
a = merge(a, estimado_times_terra, all = TRUE)
a = merge(a, estimado_times_g1, all = TRUE)

a %>% 
    ggplot(aes(
        ymin = conf.low,
        y = statistic,
        ymax = conf.high,
        x = site
    )) +
    geom_linerange() +
    geom_point(color = "red", size = 1) +
    geom_text(
        aes(
            y = conf.high,
            label = str_glue("[{round(conf.low, 2)}, {round(conf.high, 2)}]")
        ),
        size = 3,
        nudge_x = -.2,
        show.legend = F
    )  +
    scale_y_continuous(limits = c(0.25, 1.5)) +
    labs(
        title = "Tempo estimado em segundos para sites",
        x = "sites", y = "") +
    coord_flip()

2. Qual o tamanho da diferença entre o(s) mais rápido(s) e os mais lentos?

A partir do gráfico anterior esperamos que os sites mais rápidos são uol e folha, como consequência, os mais lentos são terra e g1. Fazendo o bootstrap da diferença da média na reamostragem dos tempos de requisição aos sites podemos ver que o uol é ligeramente mais rápido que o folha. Já para o caso dos sites terra e g1, o terra possui uma diferença significamente maior (bem mais rápido) quando comparado ao g1 se vermos a comparação entre os mais rápidos.

s_uol_folha <- function(d, i) {
    a = d[i,] %>% 
      filter(site == "uol") %>%
      summarise(mean_time = mean(time)) %>%
      pull(mean_time)
    
    b = d[i,] %>% 
      filter(site == "folha") %>%
      summarise(mean_time = mean(time)) %>%
      pull(mean_time)
    
    a - b
}

booted <- boot(data = requests_portais, 
               statistic = s_uol_folha, 
               R = 2000)

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

glimpse(estimado_uol_folha)

## Rows: 1
## Columns: 5
## $ statistic <dbl> -0.02353193
## $ bias      <dbl> 8.290578e-05
## $ std.error <dbl> 0.007415433
## $ conf.low  <dbl> -0.04409716
## $ conf.high <dbl> -0.01205235

s_terra_g1 <- function(d, i) {
    a = d[i,] %>% 
      filter(site == "terra") %>%
      summarise(mean_time = mean(time)) %>%
      pull(mean_time)
    
    b = d[i,] %>% 
      filter(site == "g1") %>%
      summarise(mean_time = mean(time)) %>%
      pull(mean_time)
    
    a - b
}

booted <- boot(data = requests_portais, 
               statistic = s_terra_g1, 
               R = 2000)

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

glimpse(estimado_terra_g1)

## Rows: 1
## Columns: 5
## $ statistic <dbl> -0.7712579
## $ bias      <dbl> -0.0002171762
## $ std.error <dbl> 0.0166856
## $ conf.low  <dbl> -0.8053416
## $ conf.high <dbl> -0.7402248

estimado_uol_folha %>% 
    ggplot(aes(
        ymin = conf.low,
        y = statistic,
        ymax = conf.high,
        x = ""
    )) +
    geom_linerange() +
    geom_point(color = "red", size = 1) +
    geom_text(
        aes(
            y = conf.high,
            label = str_glue("[{round(conf.low, 2)}, {round(conf.high, 2)}]")
        ),
        size = 3,
        nudge_x = -.2,
        show.legend = F
    )  +
    scale_y_continuous(limits = c(-0.07, 0.07)) +
    labs(
        title = "Diferença de tempo estimado em segundos do\nsite uol versus folha",
        subtitle = str_glue("média"),
        x = "", y = "tempo em segundos") +
    coord_flip()

Agora verificando por meio de testes de hipóteses temos:

theta_chapeu_2_2 = -0.02353193

s <- function(d){
  embaralhados = d %>% filter(site %in% c("uol", "folha")) %>% mutate(k_unit_sum = sample(time, size = n()))
  
    a = embaralhados %>% 
      filter(site == "uol") %>%
      summarise(false_smile_leniency = mean(k_unit_sum)) %>% 
      pull(false_smile_leniency)
    
    b = embaralhados %>%
      filter(site == "folha") %>%
      summarise(no_smile_control_leniency = mean(k_unit_sum)) %>% 
      pull(no_smile_control_leniency)
    
    a - b
}

simulacoes_2_2 = tibble(simulacao = 1:5000) %>%
  mutate(theta_nulo = map_dbl(simulacao, ~s(requests_portais)))

simulacoes_2_2 %>%
  ggplot(aes(x = theta_nulo)) +
  geom_histogram(binwidth = .0005, fill = "coral") +
  geom_rug() +
  geom_vline(xintercept = c(-theta_chapeu_2_2, theta_chapeu_2_2)) +
  geom_text(aes(x=-theta_chapeu_2_2, label="\ntheta_chapeu", y=80), colour="black", angle=90) +
  geom_text(aes(x=theta_chapeu_2_2, label="\ntheta_chapeu", y=80), colour="black", angle=90) +
  labs(
    title = "Histograma das simulações para theta nulo\ncom interceptos de theta chapeu para\ntime dos sites mais rápidos (uol e folha)",
    subtitle = "theta_chapeu = -0.02353193 usando média"
  )

p = simulacoes_2_2 %>%
  summarise(p_valor = sum(abs(theta_nulo) >= abs(theta_chapeu_2_2)) / n(),
            .groups = "drop")

p

No teste de hipótese podemos dizer se há ou não diferença no tempo de requisição aos sites mais rápidos, pois esse método não há como medir quanto e se é relevante. Mas pelos resultados acima podemos ver que o p_valor é igual a 0, o que indica que há total indicios de rejeitar a hipotese nula (não se comporta como as simulações de theta_nulo), indicando que há uma mudança no julgamento.

estimado_terra_g1 %>% 
    ggplot(aes(
        ymin = conf.low,
        y = statistic,
        ymax = conf.high,
        x = ""
    )) +
    geom_linerange() +
    geom_point(color = "red", size = 1) +
    geom_text(
        aes(
            y = conf.high,
            label = str_glue("[{round(conf.low, 2)}, {round(conf.high, 2)}]")
        ),
        size = 3,
        nudge_x = -.2,
        show.legend = F
    )  +
    scale_y_continuous(limits = c(-1, -0.5)) +
    labs(
        title = "Diferença de tempo estimado em segundos do\nsite terra versus g1",
        subtitle = str_glue("média"),
        x = "", y = "tempo em segundos") +
    coord_flip()

3. Suas conclusões mudam se em vez da média você considerar o 75-percentil dos tempos de resposta?

Não, as mudanças foram insignificantes para ambos se compararmos a analise anterior utilizando 75-percentil.

s_q_uol_folha <- function(d, i) {
    a = d[i,] %>% 
      filter(site == "uol") %>%
      summarise(mean_time = quantile(time, 0.75)) %>%
      pull(mean_time)
    
    b = d[i,] %>% 
      filter(site == "folha") %>%
      summarise(mean_time = quantile(time, 0.75)) %>%
      pull(mean_time)
    
    a - b
}

booted <- boot(data = requests_portais, 
               statistic = s_q_uol_folha, 
               R = 2000)

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

glimpse(estimado_uol_folha_q)

## Rows: 1
## Columns: 6
## $ term      <chr> "75%"
## $ statistic <dbl> -0.019703
## $ bias      <dbl> -0.0008011284
## $ std.error <dbl> 0.003841134
## $ conf.low  <dbl> -0.026748
## $ conf.high <dbl> -0.01359154

s_q_terra_g1 <- function(d, i) {
    a = d[i,] %>% 
      filter(site == "terra") %>%
      summarise(mean_time = quantile(time, 0.75)) %>%
      pull(mean_time)
    
    b = d[i,] %>% 
      filter(site == "g1") %>%
      summarise(mean_time = quantile(time, 0.75)) %>%
      pull(mean_time)
    
    a - b
}

booted <- boot(data = requests_portais, 
               statistic = s_q_terra_g1, 
               R = 2000)

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

glimpse(estimado_terra_g1_q)

## Rows: 1
## Columns: 6
## $ term      <chr> "75%"
## $ statistic <dbl> -0.8024518
## $ bias      <dbl> 0.002163864
## $ std.error <dbl> 0.02809202
## $ conf.low  <dbl> -0.8448586
## $ conf.high <dbl> -0.7327329

estimado_uol_folha_q %>% 
    ggplot(aes(
        ymin = conf.low,
        y = statistic,
        ymax = conf.high,
        x = ""
    )) +
    geom_linerange() +
    geom_point(color = "red", size = 1) +
    geom_text(
        aes(
            y = conf.high,
            label = str_glue("[{round(conf.low, 2)}, {round(conf.high, 2)}]")
        ),
        size = 3,
        nudge_x = -.2,
        show.legend = F
    )  +
    scale_y_continuous(limits = c(-0.07, 0.07)) +
    labs(
        title = "Diferença de tempo estimado em segundos do\nsite uol versus folha",
        subtitle = str_glue("75-percentil"),
        x = "", y = "tempo em segundos") +
    coord_flip()

Agora verificando por meio de testes de hipóteses temos:

theta_chapeu_2_3 = -0.019703

s <- function(d){
  embaralhados = d %>% filter(site %in% c("uol", "folha")) %>% mutate(k_unit_sum = sample(time, size = n()))
  
    a = embaralhados %>% 
      filter(site == "uol") %>%
      summarise(uol = quantile(k_unit_sum, 0.75)) %>% 
      pull(uol)
    
    b = embaralhados %>%
      filter(site == "folha") %>%
      summarise(folha = quantile(k_unit_sum, 0.75)) %>% 
      pull(folha)
    
    a - b
}

simulacoes_2_3 = tibble(simulacao = 1:5000) %>%
  mutate(theta_nulo = map_dbl(simulacao, ~s(requests_portais)))

simulacoes_2_3 %>%
  ggplot(aes(x = theta_nulo)) +
  geom_histogram(binwidth = .0005, fill = "coral") +
  geom_rug() +
  geom_vline(xintercept = c(-theta_chapeu_2_3, theta_chapeu_2_3)) +
  geom_text(aes(x=-theta_chapeu_2_3, label="\ntheta_chapeu", y=80), colour="black", angle=90) +
  geom_text(aes(x=theta_chapeu_2_3, label="\ntheta_chapeu", y=80), colour="black", angle=90) +
  labs(
    title = "Histograma das simulações para theta nulo\ncom interceptos de theta chapeu para\ntime dos sites mais rápidos (uol e folha)",
    subtitle = "theta_chapeu = -0.019703 usando 3º quantil"
  )

p = simulacoes_2_3 %>%
  summarise(p_valor = sum(abs(theta_nulo) >= abs(theta_chapeu_2_3)) / n(),
            .groups = "drop")

p

No teste de hipótese podemos dizer se há ou não diferença no tempo de requisição aos sites mais rápidos, pois esse método não há como medir quanto e se é relevante. Mas pelos resultados acima podemos ver que o p_valor é igual a 0, o que indica que há total indicios de rejeitar a hipotese nula (não se comporta como as simulações de theta_nulo), indicando que há uma mudança no julgamento.

estimado_terra_g1_q %>% 
    ggplot(aes(
        ymin = conf.low,
        y = statistic,
        ymax = conf.high,
        x = ""
    )) +
    geom_linerange() +
    geom_point(color = "red", size = 1) +
    geom_text(
        aes(
            y = conf.high,
            label = str_glue("[{round(conf.low, 2)}, {round(conf.high, 2)}]")
        ),
        size = 3,
        nudge_x = -.2,
        show.legend = F
    )  +
    scale_y_continuous(limits = c(-1, -0.5)) +
    labs(
        title = "Diferença de tempo estimado em segundos do\nsite terra versus g1",
        subtitle = str_glue("75-percentil"),
        x = "", y = "tempo em segundos") +
    coord_flip()