Os dados

set.seed(12345)

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

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

glimpse(lastfm)
## Rows: 300
## Columns: 3
## $ news        <dbl> 28, 35, 13, 24, 14, 17, 13, 21, 34, 55, 10, 33, 10, 217, …
## $ old         <dbl> 61, 194, 70, 96, 130, 67, 106, 123, 76, 78, 76, 116, 119,…
## $ mediana_pop <dbl> 6.105585, 5.376812, 5.713082, 4.564335, 5.782320, 5.53259…

Proporção de artistas novos e popularidade

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 em geral escutada por 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.

Crie intervalos com 95% de confiança.

Visão geral dos dados

Antes de tudo, precisamos entender melhor os dados e uma boa forma de fazer isso é visualizar a distribuição deles através de histogramas.

p1 <- lastfm %>%
  ggplot(aes(news)) +
  geom_histogram(bins = 25) +
  scale_x_continuous(breaks = scales::pretty_breaks(n = 10))

p2 <- lastfm %>%
  ggplot(aes(old)) +
  geom_histogram(bins = 25) +
  scale_x_continuous(breaks = scales::pretty_breaks(n = 10))

p3 <- lastfm %>%
  ggplot(aes(mediana_pop)) +
  geom_histogram(bins = 25) +
  scale_x_continuous(breaks = scales::pretty_breaks(n = 10))

grid.arrange(p1,p2,p3)

Observamos que poucos novos artistas foram escutados durante os 6 meses, concentrados entre 0 e 50, e a quantidade de artistas já conhecidos foram um pouco mais escutados nesse mesmo período, concentrados entre 50 e 100. Já a mediana da popularidade dos artistas escutados é mais bem distribuída, com uma maior concentração no valor da popularidade entre 5.5 e 6.0.

Proporção de novos artistas

Para o cálculo da proporção será considerada a relação entre o número de novos artistas e o número total de artistas, como é mostrado na fórmula: \(prop = \frac{\#news}{\#(news+old)}\)

Implementação manual

theta_prop <- function(df){
  x <- df %>% 
    mutate(prop = news/(news + old)) %>% 
    pull(prop)
  mean(x)
}

theta_c <- theta_prop(lastfm)

theta_c
## [1] 0.2483568
repeticoes = 4000

um_bootstrap <- function(df){
  df_ = df %>% mutate(prop = news/(news + old))
  prop = df_$prop
  boot_x <- sample(prop,           # amostre dos dados
                   size = NROW(prop), # tamanho igual ao recebido
                   replace = TRUE) # aqui é o bootstrap
  
  return(mean(boot_x))
}

set.seed(1212)

# A REAMOSTRAGEM
reamostragens = tibble(i = 1:repeticoes) %>% 
  mutate(theta_c_s = map_dbl(i, ~ um_bootstrap(lastfm)))

reamostragens
intervalo = reamostragens %>% 
  mutate(erro = theta_c_s - 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

Implementação com a biblioteca boot

library(boot)
library(broom)

theta <- function(df, i){
  x <- df %>% 
    slice(i) %>% 
    mutate(prop = news/(news + old)) %>% 
    pull(prop)
  mean(x)
}

booted <- boot(data = lastfm, 
               statistic = theta, 
               R = repeticoes)

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

glimpse(ci)
## Rows: 1
## Columns: 5
## $ statistic <dbl> 0.2483568
## $ bias      <dbl> -4.423431e-05
## $ std.error <dbl> 0.006736469
## $ conf.low  <dbl> 0.236029
## $ conf.high <dbl> 0.2624599

Resultados

ggplot() +
  geom_pointrange(aes(x = "Implementação manual", y = theta_c, ymin = intervalo$valor_i, ymax = intervalo$valor_s)) +
  geom_pointrange(aes(x = "Biblioteca boot", y = ci$statistic, ymin = ci$conf.low, ymax = ci$conf.high)) +
  theme(axis.title.x=element_blank()) +
  labs(y = "Proporção de novos artistas")

A implementação manual produziu \(\theta{\scriptsize manual} = 0.2483568\) e intervalo de confiança [0.2375877, 0.2594611], enquanto a implementação com a biblioteca boot retornou \(\theta{\scriptsize boot} = 0.2483568\) e intervalo de confiança [0.236029, 0.2624599] - ambas com 95% de confiança. Isso evidencia que as estatísticas produzidas foram iguais para os os dois métodos e podemos dizer que a proporção de novos artistas escutados pelos usuários é de 0.2483568, enquanto que os intervalos de confiança tiveram uma pequena variação de um método para o outro.
Com base nos resultados, temos evidencias que os usuários da plataforma consomem uma baixa proporção de novidades, de acordo com a amostra utilizada.

Correlação entre popularidade mediana e proporção de novos artistas, para usuários que gostam de músicas muito populares (mediana_pop > 5)

De forma visual, vamos plotar as duas variáveis e tentar observar alguma relação entre elas, aplicando os filtros necessários:

lastfm %>%
    filter(mediana_pop > 5) %>% 
    mutate(prop = news / (news + old) ) %>% 
    ggplot(aes(x = mediana_pop, y = prop)) +
    geom_point()

Implementação manual

Calculando a correlação entre as duas variáveis.

theta_corr <- function(df){
  x <- df %>% 
    filter(mediana_pop > 5) %>% 
    mutate(prop = news/(news + old)) %>% 
    summarise(corr = cor(mediana_pop, prop, method = 'pearson')) %>% 
    pull(corr)
  #mean(x)
  return(x)
}

theta_c_corr <- theta_corr(lastfm)

theta_c_corr
## [1] -0.088961

Fazendo o bootstrap.

repeticoes = 4000

um_bootstrap_corr <- function(df){
  boot_x <- sample_n(df,           # amostre dos dados
                   size = NROW(df), # tamanho igual ao recebido
                   replace = TRUE) # aqui é o bootstrap
  
  return(theta_corr(boot_x))
}

# A REAMOSTRAGEM
reamostragens = tibble(i = 1:repeticoes) %>% 
  mutate(theta_c_s_corr = map_dbl(i, ~ um_bootstrap_corr(lastfm)))

reamostragens

Produzindo o intervalo de confiança.

intervalo = reamostragens %>% 
  mutate(erro = theta_c_s_corr - theta_c_corr) %>% 
  summarise(erro_i = quantile(erro, .05), 
            erro_s = quantile(erro, .95))

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

Implementação com a biblioteca boot

theta_corr <- function(df, i){
  x <- df %>% 
    slice(i) %>% 
    filter(mediana_pop > 5) %>% 
    mutate(prop = news/(news + old)) %>% 
    summarise(corr = cor(mediana_pop, prop, method = 'pearson')) %>% 
    pull(corr)
  return(x)
}

booted <- boot(data = lastfm, 
               statistic = theta_corr, 
               R = repeticoes)

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

glimpse(ci)
## Rows: 1
## Columns: 5
## $ statistic <dbl> -0.088961
## $ bias      <dbl> 0.001521632
## $ std.error <dbl> 0.06872899
## $ conf.low  <dbl> -0.2305747
## $ conf.high <dbl> 0.0385279

Resultados

ggplot() +
  geom_pointrange(aes(x = "Implementação manual", y = theta_c_corr, ymin = intervalo$valor_i, ymax = intervalo$valor_s)) +
  geom_pointrange(aes(x = "Biblioteca boot", y = ci$statistic, ymin = ci$conf.low, ymax = ci$conf.high)) +
  theme(axis.title.x=element_blank()) +
  labs(y = "Correlação")

A implementação manual produziu \(\theta{\scriptsize manual} = -0.088961\) e intervalo de confiança [-0.2026794, 0.02881805], enquanto a implementação com a biblioteca boot retornou \(\theta{\scriptsize boot} = -0.088961\) e intervalo de confiança [-0.2390656, 0.04235069] - ambas com 95% de confiança. Isso evidencia que as estatísticas produzidas foram iguais para os os dois métodos e podemos dizer que a correlação entre popularidade mediana e proporção de novos artistas é -0.088961.
Com base nos resultados, a correlação existe é negativa e muito fraca, que também está de acordo com o gráfico visualizado no início da análise.