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> 25, 13, 21, 18, 10, 11, 29, 51, 23, 11, 22, 35, 77, …
## $ old         <dbl> 103, 61, 62, 180, 55, 68, 120, 45, 61, 116, 68, 83, …
## $ mediana_pop <dbl> 5.966097, 5.745970, 5.195969, 5.595928, 5.900597, 6.…

Antes de partir para as perguntas, é preciso entender o que cada coluna da nossa base de dados significa e ter uma visão geral de cada uma delas.

histogramaNews <- lastfm %>% 
  ggplot(mapping = aes(news)) +
  geom_histogram(bins= 25) +
  scale_x_continuous(breaks = scales::pretty_breaks(n = 10)) +
  labs(title = "Visão geral dados", x = "Artistas novos") + 
  theme(plot.title = element_text(hjust = 0.5))

histogramaOld <- lastfm %>% 
  ggplot(mapping = aes(old)) +
  geom_histogram(bins= 25) +
  scale_x_continuous(breaks = scales::pretty_breaks(n = 10)) +
  labs(x = "Artistas antigos")

histogramaMediana <- lastfm %>% 
  ggplot(mapping = aes(mediana_pop)) +
  geom_histogram(bins= 25) +
  scale_x_continuous(breaks = scales::pretty_breaks(n = 10)) +
  labs(x = "Mediana música pop")

grid.arrange(histogramaNews, histogramaOld, histogramaMediana)

Após observar os gráficos acima, pode-se notar que os gráficos de artistas novos e antigos são mais inclinados para a esquerda, sendo assim, percebe-se que segundo a nossa base de dados artistas novos foram pouco escutados. Já os artistas antigos foram um pouco mais escutados que os artistas novos durante o períod em que os dados foram coletados. O histograma da mediana da popularidade dos artistas escutados é inclinado para direita, mostrando uma melhor distribuição do que os gráficos anteriores.

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.

Proporção de artistas novos

Para saber qual a porporção de novos artistas em geral escutada por usuários, é necessário realizar o cálculo da proporção entre o número de novos artistas e o número total de artistas.

repeticoes = 4000
theta <- function(df, i){
  x <- df %>% 
    slice(i) %>% 
    mutate(proporcao = news/(news+old)) %>% 
    pull(proporcao) 
  mean(x)
}
booted <- boot(data = lastfm,
               statistic = theta,
               R = repeticoes)

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

glimpse(ci)
## Rows: 1
## Columns: 5
## $ statistic <dbl> 0.242366
## $ bias      <dbl> -3.137813e-06
## $ std.error <dbl> 0.005932326
## $ conf.low  <dbl> 0.2306598
## $ conf.high <dbl> 0.2542083
theta <- function(df){
  x <- df %>% 
    mutate(proporcao = news/(news + old)) %>% 
    pull(proporcao)
  mean(x)
}

thetaManual <- theta(lastfm)

thetaManual
## [1] 0.242366
bootstrapManual <- function(df){
  x = df %>% 
    mutate(proporcao = news/(news + old))
  proporcao = x$proporcao
  bootManual <- sample(proporcao,
                    size = NROW(proporcao),
                    replace = TRUE)
  return(mean(bootManual))
}

set.seed(1212)

reamostragens = tibble(i = 1:repeticoes) %>% 
  mutate(thetaManualAux = map_dbl(i, ~ bootstrapManual(lastfm)))

reamostragens
intervalo = reamostragens %>% 
  mutate(erro = thetaManualAux - thetaManual) %>% 
  summarise(erroInferior = quantile(erro, 0.05),
            erroSuperior = quantile(erro, 0.95))

intervalo = intervalo %>% 
  mutate(valorInferior = thetaManual + erroInferior,
         valorSuperior = thetaManual + erroSuperior)

intervalo

Podemos afirmar que o valor do theta do bootstrap pela biblioteca é de 0.242366 com um intervalo de confiança de [0.2306598, 0.2542083] e o valor relacionado ao bootstrap manual foi também de 0.242366 com um intervalo de confiança de [0.2325967, 0.2524944], sendo os dois com 95% de confiança. Isso significa que os resultados obtidos foram iguais para os dois métodos, sendo assim, podemos afirmar que a proporção de novos artistas em geral escutada por usuários é de 0.242366, com 95% de confiança. E os intervalos de confiança tiveram um leve variação de um método para outro.

Correlação entre a popularidade mediana dos artistas escutados e a proporção dos artistas escutados que eram novos

Para responder a questão acima, é necessário calcular a correlação entre a popularidade mediana dos artistas escutados e a porporção dos artistas escutados que eram novos. Mas, antes disso, iremos produzir uma visualização considerando as variáveis que serão utilizadas para entendermos melhor o estado da nossa base de dados.

lastfm %>% 
  filter(mediana_pop > 5) %>% 
  mutate(proporcao = news/(news + old)) %>% 
  ggplot(aes(x = mediana_pop, y = proporcao)) +
  geom_point() +
  labs(x = "Mediana da popularidade dos artistas escutados", y = "Proporção dos artistas escutados que eram novos", title = "Relação entre a Mediana da popularidade e  Proporção dos artistas escutados novos.") + 
  theme(plot.title = element_text(hjust = 0.5))

Observando o gráfico acima, não dá para afirmar algo com confiança sobre a relação entre as duas variáveis utilizadas.

thetaCorrelacao <- function(df, i){
  x <- df %>% 
    slice(i) %>% 
    filter(mediana_pop > 5) %>% 
    mutate(proporcao = news/(news + old)) %>% 
    summarise(correlacao = cor(mediana_pop, proporcao, method = "pearson")) %>% 
    pull(correlacao)
  return(x)
}

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

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

glimpse(ci)
## Rows: 1
## Columns: 5
## $ statistic <dbl> -0.05679804
## $ bias      <dbl> -0.0005231173
## $ std.error <dbl> 0.06276945
## $ conf.low  <dbl> -0.1793958
## $ conf.high <dbl> 0.06099809
thetaCorrelacao <- function(df){
  x <- df %>% 
    filter(mediana_pop > 5) %>% 
    mutate(proporcao = news/(news + old)) %>% 
    summarise(correlacao = cor(mediana_pop, proporcao, method = "pearson")) %>% 
    pull(correlacao)
  return(x)
}

thetaManualCorrelacao <- thetaCorrelacao(lastfm)

thetaManualCorrelacao
## [1] -0.05679804
bootstrapManualCorrelacao <- function(df){
  bootManual <- sample_n(df,
                         size = NROW(df),
                         replace = TRUE)
  
  return(thetaCorrelacao(bootManual))
}

reamostragens = tibble(i = 1:repeticoes) %>% 
  mutate(thetaManualCorrelacaoAux = map_dbl(i, ~ bootstrapManualCorrelacao(lastfm)))

reamostragens
intervalo = reamostragens %>% 
  mutate(erro = thetaManualCorrelacaoAux - thetaManualCorrelacao) %>% 
  summarise(erroInferior = quantile(erro, 0.05),
            erroSuperior = quantile(erro, 0.95))

intervalo = intervalo %>% 
  mutate(valorInferior = thetaManualCorrelacao + erroInferior,
         valorSuperior = thetaManualCorrelacao + erroSuperior)
intervalo

Podemos afirmar que o valor do theta do bootstrap pela biblioteca é de -0.05679804 com um intervalo de confiança de [-0.1823639, 0.05991931] e o valor relacionado ao bootstrap manual foi também de -0.05679804 com um intervalo de confiança de [-0.1622407, 0.04609812], sendo os dois com 95% de confiança. Isso significa que os resultados obtidos foram iguais para os dois métodos, sendo assim, podemos afirmar que a correlação entre a popularidade mediana dos artistas escutados e a proporção dos artistas escutados que eram novos é de -0.05679804, com 95% de confiança.