pd-alan-alonso

Pacotes

library(tidyverse)

── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
✔ dplyr     1.2.0     ✔ readr     2.2.0
✔ forcats   1.0.1     ✔ stringr   1.6.0
✔ ggplot2   4.0.2     ✔ tibble    3.3.1
✔ lubridate 1.9.5     ✔ tidyr     1.3.2
✔ purrr     1.2.1     
── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
✖ dplyr::filter() masks stats::filter()
✖ dplyr::lag()    masks stats::lag()
ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors

library(palmerpenguins)

Anexando pacote: 'palmerpenguins'

Os seguintes objetos são mascarados por 'package:datasets':

    penguins, penguins_raw

library(ggthemes)
library(nycflights13)
library(summarytools)

Anexando pacote: 'summarytools'

O seguinte objeto é mascarado por 'package:tibble':

    view

library(skimr)
library(readr)
library(gt)

Dados

O carregamento dos dados é feito a seguir, com o auxilio de uma pasta “dados” na raíz do projeto, melhorando a organização do mesmo. O glimpse é para comprovar o carregamento dos mesmos, e também serve para vizualizar o caráter float das variáveis numéricas. A base de dados escolhida foi: https://www.kaggle.com/datasets/muhammedderric/fitness-classification-dataset-synthetic

dados <- read_csv("dados/fitness_dataset.csv")

Rows: 2000 Columns: 11
── Column specification ────────────────────────────────────────────────────────
Delimiter: ","
chr (2): smokes, gender
dbl (9): age, height_cm, weight_kg, heart_rate, blood_pressure, sleep_hours,...

ℹ Use `spec()` to retrieve the full column specification for this data.
ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.

spec(dados)

cols(
  age = col_double(),
  height_cm = col_double(),
  weight_kg = col_double(),
  heart_rate = col_double(),
  blood_pressure = col_double(),
  sleep_hours = col_double(),
  nutrition_quality = col_double(),
  activity_index = col_double(),
  smokes = col_character(),
  gender = col_character(),
  is_fit = col_double()
)

glimpse(dados)

Rows: 2,000
Columns: 11
$ age               <dbl> 56, 69, 46, 32, 60, 25, 78, 38, 56, 75, 36, 40, 28, …
$ height_cm         <dbl> 152, 186, 192, 189, 175, 172, 193, 188, 164, 198, 15…
$ weight_kg         <dbl> 65, 95, 103, 83, 99, 85, 83, 57, 108, 55, 63, 55, 90…
$ heart_rate        <dbl> 69.6, 60.8, 61.4, 60.2, 58.1, 81.2, 79.6, 81.2, 70.1…
$ blood_pressure    <dbl> 117.0, 114.8, 116.4, 130.1, 115.8, 119.2, 132.5, 110…
$ sleep_hours       <dbl> NA, 7.5, NA, 7.0, 8.0, 7.7, 7.4, 6.6, 9.1, 8.1, 5.9,…
$ nutrition_quality <dbl> 2.37, 8.77, 8.20, 6.18, 9.95, 7.35, 2.16, 8.47, 4.15…
$ activity_index    <dbl> 3.97, 3.19, 2.03, 3.68, 4.83, 4.08, 3.42, 4.96, 2.06…
$ smokes            <chr> "no", "0", "0", "0", "yes", "yes", "yes", "0", "no",…
$ gender            <chr> "F", "F", "F", "M", "F", "M", "F", "M", "F", "F", "M…
$ is_fit            <dbl> 1, 1, 0, 1, 1, 0, 0, 1, 0, 0, 0, 1, 1, 1, 1, 0, 1, 0…

A escolha da base se deve primordialmente por ser um tema que estou vagamente inserido nos últimos meses, podendo portanto conectar e compreender melhor diferentes fatores de sáude. Apesar de ser uma base artificial, é bem avaliada e bastante limpa, com poucas incosistências (intencionais) por parte do seu criador.

Antes de qualquer tipo de tratamento, uma função útil para vizualizar os dados é:

dados |> 
  summary()

      age          height_cm       weight_kg        heart_rate    
 Min.   :18.00   Min.   :150.0   Min.   : 30.00   Min.   : 45.00  
 1st Qu.:34.00   1st Qu.:162.0   1st Qu.: 64.00   1st Qu.: 62.10  
 Median :49.00   Median :174.0   Median : 83.00   Median : 70.25  
 Mean   :49.11   Mean   :174.5   Mean   : 83.54   Mean   : 70.29  
 3rd Qu.:65.00   3rd Qu.:187.0   3rd Qu.:102.00   3rd Qu.: 78.42  
 Max.   :79.00   Max.   :199.0   Max.   :250.00   Max.   :118.60  
                                                                  
 blood_pressure   sleep_hours     nutrition_quality activity_index 
 Min.   : 90.0   Min.   : 4.000   Min.   : 0.000    Min.   :1.000  
 1st Qu.:109.7   1st Qu.: 6.500   1st Qu.: 2.547    1st Qu.:2.038  
 Median :120.0   Median : 7.500   Median : 5.065    Median :2.980  
 Mean   :119.9   Mean   : 7.513   Mean   : 5.035    Mean   :2.999  
 3rd Qu.:129.8   3rd Qu.: 8.600   3rd Qu.: 7.470    3rd Qu.:3.950  
 Max.   :171.2   Max.   :12.000   Max.   :10.000    Max.   :4.990  
                 NA's   :160                                       
    smokes             gender              is_fit      
 Length:2000        Length:2000        Min.   :0.0000  
 Class :character   Class :character   1st Qu.:0.0000  
 Mode  :character   Mode  :character   Median :0.0000  
                                       Mean   :0.3995  
                                       3rd Qu.:1.0000  
                                       Max.   :1.0000  
                                                       

Tratamento dos dados

Uma das incosistências da base é o “smokes” ter tanto dados como “sim” e “não” quanto com 1 e 0. Vou tratar isso e tambem converter o is_fit para “sim” e “não” seguindo um mesmo padrão.

dados <- dados %>%
  mutate(
    smokes = case_when(
      smokes %in% c("yes", "1") ~ "yes",
      smokes %in% c("no", "0")  ~ "no"
    ),
    is_fit = case_when(
      is_fit %in% c(1, "1") ~ "yes",
      is_fit %in% c(0, "0") ~ "no"
    )
  )

Tratando ainda os dados faltantes de sleep_hours, substituindo-os pela mediana da variável. A mediana é mais recomendada que a média por ser menos frágil à outliers, além de representar um valor intermediário mais fiel à maioria dos dados caso a variável seja muito assimétrica

# Opção escolhida para o tratamento dos dados faltantes: Imputar pela mediana
dados <- dados %>%
  mutate(sleep_hours = replace_na(sleep_hours, median(sleep_hours, na.rm = TRUE)))

Análise das variáveis

O primeiro passo é criar uma lista estritamente com as variáveis numéricas cuja análise de média, mediana e desvio padrão fazem sentido

dados_numericos <- dados %>%
  select(where(is.numeric))

nomes_numericas <- names(dados_numericos)
nomes_numericas

[1] "age"               "height_cm"         "weight_kg"        
[4] "heart_rate"        "blood_pressure"    "sleep_hours"      
[7] "nutrition_quality" "activity_index"   

dados_numericos <- dados %>%
  select(where(is.numeric))

dados_longos <- dados_numericos %>%
  pivot_longer(
    everything(),
    names_to = "variavel",
    values_to = "valor"
  )

ggplot(dados_longos, aes(x = "", y = valor)) +
  geom_boxplot(fill = "steelblue", alpha = 0.7) +
  facet_wrap(~ variavel, scales = "free") +
  labs(
    title = "Boxplots das variáveis numéricas",
    x = "",
    y = "Valor"
  ) +
  theme_minimal()

Com base nesses dados, apesar de buscar preservar ao máximo a integridade dos dados, vou retirar exclusivamente os outliers de weigth_kg visto que são o dobro do terceiro quartil

Q1 <- quantile(dados$weight_kg, 0.25, na.rm = TRUE)
Q3 <- quantile(dados$weight_kg, 0.75, na.rm = TRUE)
IQR_peso <- IQR(dados$weight_kg, na.rm = TRUE)

limite_inferior <- Q1 - 1.8 * IQR_peso
limite_superior <- Q3 + 1.8 * IQR_peso

dados_tratados <- dados %>%
  filter(weight_kg >= limite_inferior & weight_kg <= limite_superior)

nrow(dados) - nrow(dados_tratados)

[1] 21

Para tratar os outliers da variável de peso, foi utilizado um critério do intervalo interquartil. Primeiro, foram calculados o primeiro quartil (Q1), o terceiro quartil (Q3) e o IQR. Em seguida, foram definidos os limites inferior e superior usando a regra de 1,8 × IQR (é comum se usar uma regra de 1,5, mas busquei ser mais conservador quanto à perder dados). Por fim, foram mantidas apenas as observações cujo peso estava dentro desse intervalo, removendo os valores extremos. Uma vez que apenas 21 linhas foram perdidas, esotu satisfeito com a integridade da base e vou continuar a análise com os dados restantes.

dados_numericos <- dados_tratados |>
  select(where(is.numeric))

resumo_variaveis <- data.frame(
  media = sapply(dados_numericos, mean, na.rm = TRUE),
  mediana = sapply(dados_numericos, median, na.rm = TRUE),
  desvio_padrao = sapply(dados_numericos, sd, na.rm = TRUE),
  q25 = sapply(dados_numericos, function(x) quantile(x, 0.25, na.rm = TRUE)),
  q75 = sapply(dados_numericos, function(x) quantile(x, 0.75, na.rm = TRUE))
)

resumo_variaveis

                       media mediana desvio_padrao     q25    q75
age                49.105104   49.00     17.906116  34.000  65.00
height_cm         174.559879  174.00     14.375396 162.000 187.00
weight_kg          82.102577   82.00     21.799252  63.000 101.00
heart_rate         70.322638   70.30     11.859305  62.100  78.50
blood_pressure    119.919303  120.00     14.606864 109.700 129.80
sleep_hours         7.511319    7.50      1.444229   6.600   8.40
nutrition_quality   5.038474    5.07      2.865765   2.540   7.47
activity_index      2.998681    2.98      1.136476   2.035   3.94

Utilizei essa função “sapply” que organiza melhor cada um dos parâmetros pedidos em uma tabela única. Analisei também a mediana, que foi previamente usada para imputar os dados faltantes de sleep_hours.

dados_numericos <- dados_tratados %>%
  select(where(is.numeric))

summarytools::descr(dados_numericos)

Descriptive Statistics  
dados_numericos  
N: 1979  

                    activity_index       age   blood_pressure   heart_rate   height_cm
----------------- ---------------- --------- ---------------- ------------ -----------
             Mean             3.00     49.11           119.92        70.32      174.56
          Std.Dev             1.14     17.91            14.61        11.86       14.38
              Min             1.00     18.00            90.00        45.00      150.00
               Q1             2.03     34.00           109.70        62.10      162.00
           Median             2.98     49.00           120.00        70.30      174.00
               Q3             3.94     65.00           129.80        78.50      187.00
              Max             4.99     79.00           171.20       118.60      199.00
              MAD             1.41     22.24            14.83        12.16       17.79
              IQR             1.90     31.00            20.10        16.40       25.00
               CV             0.38      0.36             0.12         0.17        0.08
         Skewness             0.05     -0.04             0.10         0.14        0.01
      SE.Skewness             0.06      0.06             0.06         0.06        0.06
         Kurtosis            -1.15     -1.17            -0.27        -0.13       -1.19
          N.Valid          1979.00   1979.00          1979.00      1979.00     1979.00
                N          1979.00   1979.00          1979.00      1979.00     1979.00
        Pct.Valid           100.00    100.00           100.00       100.00      100.00

Table: Table continues below

 

                    nutrition_quality   sleep_hours   weight_kg
----------------- ------------------- ------------- -----------
             Mean                5.04          7.51       82.10
          Std.Dev                2.87          1.44       21.80
              Min                0.00          4.00       30.00
               Q1                2.54          6.60       63.00
           Median                5.07          7.50       82.00
               Q3                7.47          8.40      101.00
              Max               10.00         12.00      119.00
              MAD                3.66          1.33       28.17
              IQR                4.93          1.80       38.00
               CV                0.57          0.19        0.27
         Skewness                0.01         -0.02       -0.07
      SE.Skewness                0.06          0.06        0.06
         Kurtosis               -1.20          0.02       -1.12
          N.Valid             1979.00       1979.00     1979.00
                N             1979.00       1979.00     1979.00
        Pct.Valid              100.00        100.00      100.00

Além da tabela-resumo construída anteriormente, foi utilizada a função descr(), do pacote summarytools, para gerar uma descrição estatística geral das variáveis numéricas da base. Essa função complementa a análise ao apresentar medidas adicionais de dispersão e posição.

dados_tratados %>% count(smokes) %>% mutate(proporcao = n / sum(n))

# A tibble: 2 × 3
  smokes     n proporcao
  <chr>  <int>     <dbl>
1 no      1088     0.550
2 yes      891     0.450

dados_tratados %>% count(gender) %>% mutate(proporcao = n / sum(n))

# A tibble: 2 × 3
  gender     n proporcao
  <chr>  <int>     <dbl>
1 F       1018     0.514
2 M        961     0.486

dados_tratados %>% count(is_fit) %>% mutate(proporcao = n / sum(n))

# A tibble: 2 × 3
  is_fit     n proporcao
  <chr>  <int>     <dbl>
1 no      1185     0.599
2 yes      794     0.401

categoricas <- dados_tratados %>%
  select(where(~ is.character(.x) || is.factor(.x)))

nomes_categoricas <- names(categoricas)

for (var in nomes_categoricas) {
  print(
    ggplot(dados_tratados, aes(x = .data[[var]])) +
      geom_bar(fill = "steelblue", color = "white") +
      labs(
        title = paste("Gráfico de barras de", var),
        x = var,
        y = "Frequência"
      ) +
      theme_minimal()
  )
}

dados_numericos <- dados_tratados %>%
  select(where(is.numeric))

for (var in names(dados_numericos)) {
  
  grafico <- ggplot(dados_tratados, aes(x = .data[[var]])) +
    labs(
      title = paste("Histograma de", var),
      x = var,
      y = "Frequência"
    ) +
    theme_minimal()
  
  if (var == "nutrition_quality") {
    
    grafico <- grafico +
      geom_histogram(
        binwidth = 1,
        boundary = -0.5,
        fill = "steelblue",
        color = "white"
      ) +
      scale_x_continuous(
        breaks = 0:10,
        limits = c(-0.5, 10.5)
      )
    
  } else if (var == "activity_index") {
    
    grafico <- grafico +
      geom_histogram(
        binwidth = 1,
        boundary = 0.5,
        fill = "steelblue",
        color = "white"
      ) +
      scale_x_continuous(
        breaks = 1:5,
        limits = c(0.5, 5.5)
      )
    
  } else {
    
    grafico <- grafico +
      geom_histogram(
        bins = nclass.Sturges(dados_numericos[[var]]),
        fill = "steelblue",
        color = "white"
      )
  }
  
  print(grafico)
}

Para a construção dos histogramas, foi adotado um critério diferente conforme o tipo de variável. Nas variáveis numéricas contínuas e naturais, como idade, altura, peso, frequência cardíaca, pressão arterial e horas de sono, o número de bins foi definido pelo critério de Sturges, método adequado para análises exploratórias iniciais, pois estima uma quantidade equilibrada de bins com base no tamanho da amostra.

Já as variáveis nutrition_quality e activity_index receberam tratamento especial, pois embora sejam ainda numéricas e contínuas, assumem apenas valores em escalas limitadas. Por isso, em vez de usar o critério de Sturges, foi definido binwidth = 1 e boundary foi ajustado para percorrer exatamente cada unicade na escala, de 0 a 10 ou de 1 a 5 em cada um dos casos..

Nota-se que apenas as variáveis heart_rate, blood_pressure e sleep_hours seguem tradicionamentel o formato de uma normal.

Para título de comparação, vermos se a decisão de retirar os outliers de weight_kg foi acertada, segue o histograma da variável com os dados originais.

var <- "weight_kg"
bins_sturges <- nclass.Sturges(dados[[var]])

print(
  ggplot(dados, aes(x = .data[[var]])) +
    geom_histogram(
      bins = bins_sturges,
      fill = "steelblue",
      color = "white"
    ) +
    labs(
      title = paste("Histograma de", var),
      x = var,
      y = "Frequência"
    ) +
    theme_minimal()
)

Este gráfico mostra que foi um acerto retirar estes dados que são substancialmente destoantes dos demais.

Mapa de calor e análise de correlação

dados_cor <- dados_tratados %>%
  select(where(is.numeric))

matriz_cor <- cor(dados_cor, use = "complete.obs")

cor_long <- as.data.frame(as.table(matriz_cor)) %>%
  rename(var1 = Var1, var2 = Var2, correlacao = Freq)

ggplot(cor_long, aes(x = var1, y = var2, fill = correlacao)) +
  geom_tile(color = "white") +
  scale_fill_gradient2(
    low = "steelblue",
    mid = "white",
    high = "firebrick",
    midpoint = 0,
    limits = c(-1, 1)
  ) +
  labs(
    title = "Mapa de calor da matriz de correlação",
    x = "Variável 1",
    y = "Variável 2",
    fill = "Correlação"
  ) +
  theme_minimal() +
  theme(
    axis.text.x = element_text(angle = 45, hjust = 1)
  )

Este gráfico me ligou um alerta quanto à qualidade da base, para ter certeza renderizei também a seguinte tabela

pares_cor <- data.frame(
  var1 = rownames(matriz_cor)[row(matriz_cor)[upper.tri(matriz_cor)]],
  var2 = colnames(matriz_cor)[col(matriz_cor)[upper.tri(matriz_cor)]],
  correlacao = matriz_cor[upper.tri(matriz_cor)]
) %>%
  mutate(
    par = paste(var1, var2, sep = " - "),
    correlacao = round(correlacao, 3),
    cor_abs = round(abs(correlacao), 3)
  ) %>%
  arrange(desc(cor_abs)) %>%
  select(par, correlacao, cor_abs)

pares_cor

                                  par correlacao cor_abs
1          height_cm - blood_pressure     -0.069   0.069
2          weight_kg - activity_index     -0.037   0.037
3  nutrition_quality - activity_index      0.037   0.037
4                age - blood_pressure     -0.036   0.036
5                     age - weight_kg      0.031   0.031
6                   age - sleep_hours     -0.030   0.030
7     sleep_hours - nutrition_quality     -0.030   0.030
8        sleep_hours - activity_index     -0.030   0.030
9          height_cm - activity_index      0.027   0.027
10        heart_rate - activity_index      0.025   0.025
11              height_cm - weight_kg      0.024   0.024
12                   age - heart_rate     -0.023   0.023
13               age - activity_index      0.021   0.021
14             height_cm - heart_rate     -0.019   0.019
15      height_cm - nutrition_quality      0.019   0.019
16        heart_rate - blood_pressure      0.017   0.017
17 blood_pressure - nutrition_quality     -0.012   0.012
18    blood_pressure - activity_index      0.012   0.012
19       blood_pressure - sleep_hours     -0.008   0.008
20                    age - height_cm      0.006   0.006
21             weight_kg - heart_rate      0.006   0.006
22            age - nutrition_quality      0.005   0.005
23            weight_kg - sleep_hours      0.003   0.003
24            height_cm - sleep_hours      0.002   0.002
25           heart_rate - sleep_hours     -0.001   0.001
26     heart_rate - nutrition_quality      0.001   0.001
27         weight_kg - blood_pressure      0.000   0.000
28      weight_kg - nutrition_quality      0.000   0.000

Pegando apenas a parte “superior” da matriz já é suficiente para não repetir os pares. A base aparentemente não possui nenhuma correlação forte, o que pode ser esperado de um dataset artificial, mas depõe contra a qualidade da mesma, se tornando um pouco irreal que nem mesmo altura e peso tem alguma relação.

ggplot(dados_tratados, aes(x = height_cm, y = blood_pressure)) +
  geom_point(color = "steelblue", alpha = 0.6) +
  geom_smooth(method = "lm", se = FALSE, color = "red") +
  labs(
    title = "Scatterplot entre height_cm e blood_pressure",
    x = "Altura (cm)",
    y = "Pressão arterial"
  ) +
  theme_minimal()

`geom_smooth()` using formula = 'y ~ x'

Como esperado, esse gráfico não mostra uma grande correlação, mas sim uma aproximadamente -0,07. Por ser negativa, a linha tem inclinação para baixo, e por ter um módulo tão baixo essa inclinação é tão leve.

dados_linha <- dados_tratados %>%
  group_by(weight_kg) %>%
  summarise(
    media_height = mean(height_cm, na.rm = TRUE),
  )

ggplot(dados_linha, aes(x = weight_kg)) +
  geom_line(aes(y = media_height, color = "Height_cm"), linewidth = 1) +
  labs(
    title = "Média de height_cm por weight_kg",
    x = "Peso",
    y = "Valor médio de altura"
  ) +
  theme_minimal()

Para este gráfico achei que faria mais sentido usar uma média de altura para cada valor de peso, “emulando” um gráfico temporal onde para cada valor de X temos apenas um Y. Novamente, fica claro pelo gráfico que a base não possui relação entre variáveis, ainda que a existência dessa relação seja óbvia.

Este relatório também pode ser encontrado em: https://rpubs.com/AlanAlonso/pd-estatistica