Estudo central

Utilizaremos ICs para estimar duas métricas sobre os usuários do LastFM em geral durante um período de 6 meses. Em ambos os casos faremos isso a partir de uma amostra de 300 usuários. As duas métricas são:

  1. Qual a proporção de novos artistas escutados pelos usuários
  2. Para os usuários que gostam de música muito pop (mediana_pop > 5), qual a correlação entre a popularidade mediana dos artistas escutado e a proporção dos artistas escutados que eram novos.

Os dados

set.seed(1110)

lastfm = read_csv(here::here("data/experimento-lastfm.csv"), 
                  col_types = cols(.default = col_double(), 
                                   user = col_character()))

amostra = lastfm %>% 
  sample_n(300) %>% 
  select(news, old, mediana_pop)

glimpse(amostra)
## Observations: 300
## Variables: 3
## $ news        <dbl> 26, 26, 27, 28, 26, 26, 27, 13, 24, 109, 14, 23, 15,…
## $ old         <dbl> 40, 54, 93, 152, 73, 73, 54, 55, 79, 278, 63, 43, 12…
## $ mediana_pop <dbl> 6.015763, 6.101833, 5.186340, 5.107730, 5.841306, 5.…

Proporção

Achando a proporção de novos artistas

amostra = amostra %>%
  mutate(prop = news/(news+old),
         popao = mediana_pop > 5)

funcao_theta = function(df) {
  df %>%
    pull(prop) %>%
    mean()
}

theta_c = funcao_theta(amostra)

theta_c
## [1] 0.2504801

A proporção de novos artistas escutados pelos usuários da minha amostra é de 0.2504801, ou seja, usuários escutam cerca 1 artista novo a cada 3 que ele já conhecia, em média.

Criando bootstraps

repeats = 3000

bootstrap = function(x) {
  props = x %>% pull(prop)
  boot_x = sample(props,
                  size = NROW(x),
                  replace = TRUE)
  
  return(mean(boot_x))
}

set.seed(1337)

reamostras = tibble(i = 1:repeats) %>%
  mutate(theta_cs = map_dbl(i, ~ bootstrap(amostra)))

reamostras

A técnica de bootstraps foi utilizada para criar um intervalo de confiança para meus dados. Bootstraps consiste em criar novas amostras, com reposição, a partir da amostra que já tenho.

Criando intervalo

intervalo = reamostras %>%
  mutate(erro = theta_cs - theta_c) %>%
  summarise(erro_i = quantile(erro, .05),
            erro_s = quantile(erro, .95))

intervalo = intervalo %>% 
  mutate(valor_i = theta_c + erro_i, 
         valor_s = theta_c + erro_s)

intervalo

Com a confiança dos dados de 95%, encontrei 0.2397322 e 0.2607974 como valores mínimo e máximo, respectivamente, confiáveis para estimar minha proporção.

Plot histograma com IC da proporção de novos artistas

ggplot() +
  geom_rect(
    data = intervalo,
    aes(xmin = valor_i, xmax = valor_s),
    ymin = -Inf,
    ymax = Inf,
    fill = "blue",
    alpha = .25
  ) +
  geom_histogram(
    data = reamostras,
    aes(x = theta_cs),
    binwidth = 0.0015,
    fill = "yellow",
    colour = "black"
  ) +
  geom_vline(xintercept = theta_c, color = "dark green") +
  labs(title = expression("Intervalo estimado via bootstrap"),
       x = "Theta das reamostras",
       y = "Quantidade de reamostras")

Uma visualização do resultado. O retângulo azul simboliza até onde vai o intervalo de confiança, gerado pelas reamostras(bootstraps), e a linha verde mostra a média da proporção que achei a partir da amostra.

Utilizando a biblioteca boot

library(boot)

theta <- function(d, i) {
    agrupado = d %>% 
        slice(i) %>% 
        summarise(media = mean(prop)) %>%
        pull(media)
}

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

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

glimpse(ci)
## Observations: 1
## Variables: 5
## $ statistic <dbl> 0.2504801
## $ bias      <dbl> 0.0002376123
## $ std.error <dbl> 0.006408276
## $ conf.low  <dbl> 0.2382736
## $ conf.high <dbl> 0.2630547

Plot de IC da proporção de novos artistas

ci %>%
    ggplot(aes(
        x = "",
        y = statistic,
        ymin = conf.low,
        ymax = conf.high
    )) +
    geom_pointrange() +
    geom_point(size = 3, color = "blue") +
  labs(title = expression("Intervalo estimado via bootstrap"),
       x = "",
       y = "Intervalo de Confiança")

Uma maneira diferente de ver os mesmos dados, com o ponto representando a porpoção obtida da amostra e com as caudas representando o intervalo de confiança.

De maneira geral essa proporção é relativamente normal e acredito que expressa bem a realidade dos usuários, é bem comum a maioria das pessoas escutar mais os artistas que elas já conhecem a maior parte do tempo (provavelmente estou nessa faixa de resultados também).

Correlação

Correlação entre artistas populares e a proporção de novos artistas

amostraZ = amostra %>%
  filter(popao == TRUE)

funcao_theta = function(x) {
  x %>%
    mutate(corr = cor(mediana_pop, prop, method = "spearman")) %>%
    pull(corr) %>%
    mean()
}

theta_c = funcao_theta(amostraZ)

theta_c
## [1] -0.02717663

Criando bootstraps

repeats = 3000

bootstrapZ = function(x) {
  reamostra = x %>% 
    sample_n(size = NROW(x), 
             replace = TRUE) %>% 
    select(mediana_pop, prop)
  
  reamostra = reamostra %>%
    mutate(corr = cor(mediana_pop, prop, method = "spearman")) %>%
    pull(corr)
  
  return(mean(reamostra))
}

set.seed(1337)

reamostrasZ = tibble(i = 1:repeats) %>%
  mutate(theta_cs = map_dbl(i, ~ bootstrapZ(amostraZ)))

reamostrasZ

Criando intervalo

intervaloZ = reamostrasZ %>%
  mutate(erro = theta_cs - theta_c) %>%
  summarise(erro_i = quantile(erro, .05),
            erro_s = quantile(erro, .95))

intervaloZ = intervaloZ %>% 
  mutate(valor_i = theta_c + erro_i, 
         valor_s = theta_c + erro_s)

intervaloZ

Plot histograma com IC da correlação

ggplot() +
  geom_rect(
    data = intervaloZ,
    aes(xmin = valor_i, xmax = valor_s),
    ymin = -Inf,
    ymax = Inf,
    fill = "blue",
    alpha = .25
  ) +
  geom_histogram(
    data = reamostrasZ,
    aes(x = theta_cs),
    binwidth = 0.015,
    fill = "yellow",
    colour = "black"
  ) +
  geom_vline(xintercept = theta_c, color = "dark green") +
  labs(title = expression("Intervalo estimado via bootstrap"),
       x = "Theta das reamostras",
       y = "Quantidade de reamostras")

Uma visualização do resultado. O retângulo azul simboliza até onde vai o intervalo de confiança, gerado a partir das reamostras(bootstraps), e a linha verde mostra a correlação que achei a partir da amostra.

Utilizando a biblioteca boot

library(boot)

thetaZ <- function(d, i) {
    agrupado = d %>% 
        slice(i) %>% 
        summarise(media = mean(cor(mediana_pop, prop, method = "spearman"))) %>%
        pull(media)
}

bootedZ <- boot(data = amostraZ, 
               statistic = thetaZ, 
               R = 2000)

ciZ = tidy(bootedZ, 
          conf.level = .95,
          conf.method = "bca",
          conf.int = TRUE)

glimpse(ciZ)
## Observations: 1
## Variables: 5
## $ statistic <dbl> -0.02717663
## $ bias      <dbl> 0.001257846
## $ std.error <dbl> 0.06278244
## $ conf.low  <dbl> -0.1539713
## $ conf.high <dbl> 0.09098275

Plot de IC da correlação

ciZ %>%
    ggplot(aes(
        x = "",
        y = statistic,
        ymin = conf.low,
        ymax = conf.high
    )) +
    geom_pointrange() +
    geom_point(size = 3, color = "blue") +
  labs(title = expression("Intervalo estimado via bootstrap"),
       x = "",
       y = "Intervalo de Confiança")

A correlação entre os usuários que escutam artistas populares e a proporção de artistas novos escutados por eles também é baixa e negativa, logo quanto mais popular são os artistas que você escuta menos você procura por novos artistas, enquanto quem escuta artistas menos conhecidos tendem a procurar mais artistas.