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:

Para smile:

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:

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.37, 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.0004310443
## $ std.error <dbl> 0.3083595
## $ conf.low  <dbl> 0.3530647
## $ conf.high <dbl> 1.556124
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()

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.003002503
## $ std.error <dbl> 0.3598541
## $ conf.low  <dbl> 0.0625743
## $ conf.high <dbl> 1.442503
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.02347787
## $ std.error <dbl> 0.3833557
## $ conf.low  <dbl> 0.03718265
## $ conf.high <dbl> 1.530495
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.002979248
## $ std.error <dbl> 0.4167125
## $ conf.low  <dbl> 0.4443666
## $ conf.high <dbl> 2.093359
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()

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()

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()

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:

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> -6.791626e-05
## $ std.error <dbl> 0.003619449
## $ conf.low  <dbl> 0.3512425
## $ conf.high <dbl> 0.3698038
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> -4.641199e-05
## $ std.error <dbl> 0.009130755
## $ conf.low  <dbl> 0.6595155
## $ conf.high <dbl> 0.7001364
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> -2.056824e-05
## $ std.error <dbl> 0.006142776
## $ conf.low  <dbl> 0.37153
## $ conf.high <dbl> 0.4011573
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> -0.0003831165
## $ std.error <dbl> 0.01393562
## $ conf.low  <dbl> 1.421372
## $ conf.high <dbl> 1.477266
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> 0.000116549
## $ std.error <dbl> 0.007111144
## $ conf.low  <dbl> -0.04322706
## $ conf.high <dbl> -0.01317664
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.0008017462
## $ std.error <dbl> 0.01663017
## $ conf.low  <dbl> -0.8078898
## $ conf.high <dbl> -0.7416515
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()

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.0009815809
## $ std.error <dbl> 0.003935678
## $ conf.low  <dbl> -0.02655079
## $ conf.high <dbl> -0.01331481
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.002349222
## $ std.error <dbl> 0.02621153
## $ conf.low  <dbl> -0.8430855
## $ conf.high <dbl> -0.73326
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()

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()