Prediksi Orang Yang Overweight/Obese

Objective

Pada kesempatan kali ini, saya akan mencoba melakukan prediksi mengenai seseorang yang Overweight dengan berdasarkan kategori dari beberapa variabel penunjangnya. Algoritma yang akan saya gunakan yaitu menggunakan logistik regression dan k-nearest neighbor yang termasuk dalam supervised learning.

Library and Setup

Sebelum itu kita harus melakukan install.package() pada package dplyr, gtools, gmodels, ggplot2, class, tidyr, caret pada R Studio. Apabila telah ter-install, maka lakukan pengaktifan package menggunakan library().

library(dplyr)
## 
## Attaching package: 'dplyr'
## The following objects are masked from 'package:stats':
## 
##     filter, lag
## The following objects are masked from 'package:base':
## 
##     intersect, setdiff, setequal, union
library(gtools)
## Warning: package 'gtools' was built under R version 4.3.1
library(gmodels)
## Warning: package 'gmodels' was built under R version 4.3.1
library(ggplot2)
library(class)
library(tidyr)
## Warning: package 'tidyr' was built under R version 4.3.1
library(caret)
## Warning: package 'caret' was built under R version 4.3.1
## Loading required package: lattice

Logistic Regression

Load Import

Dataset yang akan saya gunakan yaitu data mengenai seseorang yang diprediksi Overweight/Obese. berdasarkan beberapa karakteristik yang menyertai serta dapat anda unduh langsung pada Kaggle.

heal <- read.csv("data_input/Health_lifestyle.csv")
str(heal)
## 'data.frame':    374 obs. of  13 variables:
##  $ Person.ID              : int  1 2 3 4 5 6 7 8 9 10 ...
##  $ Gender                 : chr  "Male" "Male" "Male" "Male" ...
##  $ Age                    : int  27 28 28 28 28 28 29 29 29 29 ...
##  $ Occupation             : chr  "Software Engineer" "Doctor" "Doctor" "Sales Representative" ...
##  $ Sleep.Duration         : num  6.1 6.2 6.2 5.9 5.9 5.9 6.3 7.8 7.8 7.8 ...
##  $ Quality.of.Sleep       : int  6 6 6 4 4 4 6 7 7 7 ...
##  $ Physical.Activity.Level: int  42 60 60 30 30 30 40 75 75 75 ...
##  $ Stress.Level           : int  6 8 8 8 8 8 7 6 6 6 ...
##  $ BMI.Category           : chr  "Overweight" "Normal" "Normal" "Obese" ...
##  $ Blood.Pressure         : chr  "126/83" "125/80" "125/80" "140/90" ...
##  $ Heart.Rate             : int  77 75 75 85 85 85 82 70 70 70 ...
##  $ Daily.Steps            : int  4200 10000 10000 3000 3000 3000 3500 8000 8000 8000 ...
##  $ Sleep.Disorder         : chr  "None" "None" "None" "Sleep Apnea" ...

Informasi penting dalam data :

  • Person.ID : Pengidentifikasi untuk setiap individu.

  • Gender : Jenis kelamin orang (Pria / Wanita).

  • Age : Usia seseorang dalam tahun.

  • Occupation : Pekerjaan atau profesi orang tersebut.

  • Sleep.Duration : Jumlah jam orang tidur per hari.

  • Quality.of.Sleep : Peringkat subyektif dari kualitas tidur, mulai dari 1 hingga 10.

  • Physical.Activity.Level : Jumlah menit seseorang melakukan aktivitas fisik setiap hari.

  • Stress.Level : Peringkat subyektif dari tingkat stres yang dialami oleh orang tersebut, mulai dari 1 hingga 10.

  • BMI.Category : Kategori BMI orang tersebut (misalnya, Berat Badan Kurang, Normal, Kelebihan Berat Badan).

  • Blood.Pressure : Pengukuran tekanan darah seseorang, diindikasikan sebagai tekanan sistolik di atas tekanan diastolik.

  • Heart.Rate : Detak jantung istirahat seseorang dalam detak per menit.

  • Daily.Steps : Jumlah langkah yang dilakukan seseorang per hari.

  • Sleep.Disorder : Ada atau tidaknya gangguan tidur pada seseorang (None, Insomnia, Sleep Apnea).

Berikut ini sedikit gambaran pada data yang digunakan.

head(heal)

Data Manipulation

Pada beberapa variabel yang digunakan, terdapat ketidaksesuaian tipe data, oleh karena itu yang perlu kita lakukan adalah melakukan penyesuaian tipe data pada beberapa variabel yang ada.

heal <- heal %>% 
  mutate(Gender = as.factor(Gender), 
         Occupation = as.factor(Occupation), 
         BMI.Category = as.factor(BMI.Category), 
         Blood.Pressure = as.factor(Blood.Pressure), 
         Sleep.Disorder = as.factor(Sleep.Disorder)) %>% 
  select(-Person.ID)
head(heal)

Selanjutnya yaitu melakukan pengecekan terhadap missing value. Missing value perlu kita cek terlebih dahulu agar tidak mengganggu dalam melakukan pemodelan nantinya.

colSums(is.na(heal))
##                  Gender                     Age              Occupation 
##                       0                       0                       0 
##          Sleep.Duration        Quality.of.Sleep Physical.Activity.Level 
##                       0                       0                       0 
##            Stress.Level            BMI.Category          Blood.Pressure 
##                       0                       0                       0 
##              Heart.Rate             Daily.Steps          Sleep.Disorder 
##                       0                       0                       0

Pre-Processing Data

Sebelum melakukan pemodelan, kita perlu melihat terlebih dahulu proporsi dari target variabel yang kita miliki pada kolom BMI.Category.

prop.table(table(heal$BMI.Category))
## 
##        Normal Normal Weight         Obese    Overweight 
##    0.52139037    0.05614973    0.02673797    0.39572193

Menggabungkan kategori “Normal”&“Normal Weight” = “Normal” Menggabungkan kategori “Obese”&“Overweight” = “Overweight”

heal$New_BMI_Category <- ifelse(heal$BMI.Category %in% c("Normal", "Normal Weight"), "Normal", "Overweight")


heal$New_BMI_Category <- as.factor(heal$New_BMI_Category)

cek kembali proporsi dari target variabel yang sudah digabungkan dengan nama kolom baru New_BMI_Category.

prop.table(table(heal$New_BMI_Category))
## 
##     Normal Overweight 
##  0.5775401  0.4224599
table(heal$New_BMI_Category)
## 
##     Normal Overweight 
##        216        158

Jika dilihat dari proporsi kedua kelas, sudah cukup seimbang, sehingga kita tidak terlalu membutuhkan pre-processing tambahan untuk menyeimbangkan proporsi antar dua kelas target variabel.

Splitting Train-Test

Langkah selanjutnya yaitu melakukan splitting train test data. Tujuannya yaitu pada data train akan kita gunakan untuk modeling, sedangkan data test akan kita gunakan sebagai penguji model yang sudah kita buat jika dihadapkan dengan unseen data. Selain itu hal ini dapat digunakan untuk melihat kemampuan model yang kita buat dalam menghadapi unseen data.

set.seed(123)

index <- sample(x = nrow(heal), size = nrow(heal)*0.8)

heal_train <- heal[index,]
heal_test <- heal[-index,]

nrow(heal_train)
## [1] 299
nrow(heal_test)
## [1] 75

Proporsi 0.8/0.2 tidak mutlak, tergantung kebutuhan kita. Umumnya yang lebih banyak adalah untuk data train, supaya model punya data yang banyak untuk training.

Modelling

Melakukan pemodelan menggunakan regresi logistik. Pemodelan menggunakan fungsi glm() dalam memodelkan menggunakan regresi logistik. Variabel yang digunakan adalah beberapa variabel yang kita anggap mempengaruhi target variabel, dimana variabel target menjadi variabel responnya.

model_heal <- glm(formula = New_BMI_Category ~ Age + Quality.of.Sleep+Stress.Level + Physical.Activity.Level + Heart.Rate, 
                  data = heal_train, 
                  family = "binomial")
summary(model_heal)
## 
## Call:
## glm(formula = New_BMI_Category ~ Age + Quality.of.Sleep + Stress.Level + 
##     Physical.Activity.Level + Heart.Rate, family = "binomial", 
##     data = heal_train)
## 
## Coefficients:
##                         Estimate Std. Error z value Pr(>|z|)    
## (Intercept)              6.62112    9.95588   0.665  0.50602    
## Age                      0.46986    0.06169   7.617 2.60e-14 ***
## Quality.of.Sleep        -5.63114    0.78929  -7.134 9.72e-13 ***
## Stress.Level            -2.37241    0.52178  -4.547 5.45e-06 ***
## Physical.Activity.Level  0.02316    0.01507   1.537  0.12423    
## Heart.Rate               0.36299    0.12150   2.987  0.00281 ** 
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 409.401  on 298  degrees of freedom
## Residual deviance:  82.641  on 293  degrees of freedom
## AIC: 94.641
## 
## Number of Fisher Scoring iterations: 7

Model Fitting

Pada pemodelan yang pertama, masih banyak variabel prediktor yang tidak signifikan terhadap target variabel, oleh karena itu kita akan coba melakukan model fitting menggunakan metode stepwise.

model_step <- step(object = model_heal, direction = "backward", trace = F)
summary(model_step)
## 
## Call:
## glm(formula = New_BMI_Category ~ Age + Quality.of.Sleep + Stress.Level + 
##     Physical.Activity.Level + Heart.Rate, family = "binomial", 
##     data = heal_train)
## 
## Coefficients:
##                         Estimate Std. Error z value Pr(>|z|)    
## (Intercept)              6.62112    9.95588   0.665  0.50602    
## Age                      0.46986    0.06169   7.617 2.60e-14 ***
## Quality.of.Sleep        -5.63114    0.78929  -7.134 9.72e-13 ***
## Stress.Level            -2.37241    0.52178  -4.547 5.45e-06 ***
## Physical.Activity.Level  0.02316    0.01507   1.537  0.12423    
## Heart.Rate               0.36299    0.12150   2.987  0.00281 ** 
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 409.401  on 298  degrees of freedom
## Residual deviance:  82.641  on 293  degrees of freedom
## AIC: 94.641
## 
## Number of Fisher Scoring iterations: 7

Prediksi

Dengan menggunakan model_step hasil dari stepwise, kita akan coba prediksi menggunakan data test yang sudah kita miliki.

heal_test$prob_heal <- predict(model_step, type = "response", newdata = heal_test)

Kita akan coba melihat sebaran peluang prediksi data.

ggplot(heal_test, aes(x=prob_heal)) +
  geom_density(lwd=0.5) +
  labs(title = "Distribution of Probability Prediction Data") +
  theme_minimal()

Pada grafik diatas, dapat diinterpretasikan bahwa hasil prediksi yang dilakukan lebih condong ke arah 1 yang artinya Overweight.

heal_test$pred_heal <- factor(ifelse(heal_test$prob_heal > 0.5, "Overweight","Normal"))
heal_test[4:14, 
          c("pred_heal", "New_BMI_Category")]

Dalam syntax diatas, ketika probabilitas data test lebih dari 0.5, artinya dia normal atau tidak kegemukan.

Model Evaluation

Untuk mengevaluasi model yang telah kita buat, kita akan menggunakan confusion matrix.

library(caret)
log_conf <- confusionMatrix(heal_test$pred_heal, heal_test$New_BMI_Category, positive = "Normal")
log_conf
## Confusion Matrix and Statistics
## 
##             Reference
## Prediction   Normal Overweight
##   Normal         45          1
##   Overweight      2         27
##                                           
##                Accuracy : 0.96            
##                  95% CI : (0.8875, 0.9917)
##     No Information Rate : 0.6267          
##     P-Value [Acc > NIR] : 9.176e-12       
##                                           
##                   Kappa : 0.9151          
##                                           
##  Mcnemar's Test P-Value : 1               
##                                           
##             Sensitivity : 0.9574          
##             Specificity : 0.9643          
##          Pos Pred Value : 0.9783          
##          Neg Pred Value : 0.9310          
##              Prevalence : 0.6267          
##          Detection Rate : 0.6000          
##    Detection Prevalence : 0.6133          
##       Balanced Accuracy : 0.9609          
##                                           
##        'Positive' Class : Normal          
##

  • Re-call/Sensitivity = dari semua data aktual yang positif, seberapa mampu proporsi model saya menebak benar.v

  • Specificity = dari semua data aktual yang negatif, seberapa mampu proporsi model saya menebak yang benar.

  • Accuracy = seberapa mampu model saya menebak dengan benar target Y. v

  • Precision = dari semua hasil prediksi, seberapa mampu model saya dapat menebak benar kelas positif.

Tuning Cutoff

Digunakan untuk mengetahui threshold maksimum dari apa yang akan kita teliti.

performa <- function(cutoff, prob, ref, postarget, negtarget) 
{
  predict <- factor(ifelse(prob >= cutoff, postarget, negtarget))
  conf <- caret::confusionMatrix(predict , ref, positive = postarget)
  acc <- conf$overall[1]
  rec <- conf$byClass[1]
  prec <- conf$byClass[3]
  spec <- conf$byClass[2]
  mat <- t(as.matrix(c(rec , acc , prec, spec))) 
  colnames(mat) <- c("recall", "accuracy", "precicion", "specificity")
  return(mat)
}

co <- seq(0.01,0.80,length=100)
result <- matrix(0,100,4)

for(i in 1:100){
  result[i,] = performa(cutoff = co[i], 
                     prob = heal_test$prob_heal, 
                     ref = heal_test$New_BMI_Category, 
                     postarget = "Overweight", 
                     negtarget = "Normal")
}

data_frame("Recall" = result[,1],
           "Accuracy" = result[,2],
           "Precision" = result[,3],
           "Specificity" = result[,4],
                   "Cutoff" = co) %>% 
  gather(key = "performa", value = "value", 1:4) %>% 
  ggplot(aes(x = Cutoff, y = value, col = performa)) +
  geom_line(lwd = 1.5) +
  scale_color_manual(values = c("darkred","darkgreen","orange", "blue")) +
  scale_y_continuous(breaks = seq(0,1,0.1), limits = c(0,1)) +
  scale_x_continuous(breaks = seq(0,1,0.1)) +
  labs(title = "Tradeoff perfomance") +
  theme_minimal() +
  theme(legend.position = "top",
        panel.grid.minor.y = element_blank(),
        panel.grid.minor.x = element_blank())
## Warning: `data_frame()` was deprecated in tibble 1.1.0.
## ℹ Please use `tibble()` instead.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.

Berdasarkan Tradeoff model performance diatas, dapat kita tahu bahwa dengan cutoff 0.5 kita memperoleh nilai Recall dan Accuracy yang agak tinggi, namun nilai Specificity dan nilai Precision agak rendah.

K-Nearest Neighbour

Membuat variabel dummy dari data-data kategori yang akan digunakan dalam klasifikasi.

dmy <- dummyVars(" ~New_BMI_Category+Age+Quality.of.Sleep+Stress.Level+Physical.Activity.Level+Heart.Rate", 
                 data = heal)
dmy <- data.frame(predict(dmy, newdata = heal))
str(dmy)
## 'data.frame':    374 obs. of  7 variables:
##  $ New_BMI_Category.Normal    : num  0 1 1 0 0 0 0 1 1 1 ...
##  $ New_BMI_Category.Overweight: num  1 0 0 1 1 1 1 0 0 0 ...
##  $ Age                        : num  27 28 28 28 28 28 29 29 29 29 ...
##  $ Quality.of.Sleep           : num  6 6 6 4 4 4 6 7 7 7 ...
##  $ Stress.Level               : num  6 8 8 8 8 8 7 6 6 6 ...
##  $ Physical.Activity.Level    : num  42 60 60 30 30 30 40 75 75 75 ...
##  $ Heart.Rate                 : num  77 75 75 85 85 85 82 70 70 70 ...

Menghapus variabel dummy yang variabel sebelumnya hanya terdapat 2 kategori.

dmy$New_BMI_Category.Normal <- NULL

Mengetahui nama-nama dari variabel dummy yang terbentuk.

names(dmy)
## [1] "New_BMI_Category.Overweight" "Age"                        
## [3] "Quality.of.Sleep"            "Stress.Level"               
## [5] "Physical.Activity.Level"     "Heart.Rate"

Membentuk data training dan data testing dari data dmy yang telah terbentuk dan menggunakan fungsi sample dengan proporsi 70% untuk memilih indeks data yang akan digunakan sebagai data pelatihan.

set.seed(123)
train_indices <- sample(1:nrow(dmy), nrow(dmy) * 0.7)
dmy_train <- dmy[train_indices, 2:6]
dmy_test <- dmy[-train_indices, 2:6]
dmy_train_label <- dmy[train_indices, 1]
dmy_test_label <- dmy[-train_indices, 1]

Melakukan prediksi dengan K-NN

pred_knn <- class::knn(train = dmy_train,
                       test = dmy_test, 
                       cl = dmy_train_label, 
                       k = 17)

Membuat confusion matriks dari prediski K-NN

pred_knn_conf <- confusionMatrix(as.factor(pred_knn), as.factor(dmy_test_label),"1")
pred_knn_conf
## Confusion Matrix and Statistics
## 
##           Reference
## Prediction  0  1
##          0 63  6
##          1  4 40
##                                           
##                Accuracy : 0.9115          
##                  95% CI : (0.8433, 0.9567)
##     No Information Rate : 0.5929          
##     P-Value [Acc > NIR] : 3.739e-14       
##                                           
##                   Kappa : 0.8154          
##                                           
##  Mcnemar's Test P-Value : 0.7518          
##                                           
##             Sensitivity : 0.8696          
##             Specificity : 0.9403          
##          Pos Pred Value : 0.9091          
##          Neg Pred Value : 0.9130          
##              Prevalence : 0.4071          
##          Detection Rate : 0.3540          
##    Detection Prevalence : 0.3894          
##       Balanced Accuracy : 0.9049          
##                                           
##        'Positive' Class : 1               
##

Berdasarkan hasil confusion matrix diatas, dapat kita ketahui bahwa kemampuan model dalam menebak target Y sebesar 92,9%. Sedangkan berdasarkan data aktual orang yang memiliki status Overweight, model dapat menebak dengan benar sebesar 98,4%. berdasarkan data aktual orang yang memiliki status Normal, model dapat menebak dengan benar sebesar 85,8%. Dari keseluruhan hasil prediksi yang mampu ditebak oleh model, model mampu menebak benar kelas positif sebesar 97,7%.

Model Evaluation Logistic Regression and K-NN

eval_logit <- data_frame(Accuracy = log_conf$overall[1],
           Recall = log_conf$byClass[1],
           Specificity = log_conf$byClass[2],
           Precision = log_conf$byClass[3])

eval_knn <- data_frame(Accuracy = pred_knn_conf$overall[1],
           Recall = pred_knn_conf$byClass[1],
           Specificity = log_conf$byClass[2],
           Precision = pred_knn_conf$byClass[3])

Model Evaluation Logit

eval_logit

Model Evaluation K-NN

eval_knn

Jika dilihat dari kedua metode tersebut, yaitu dengan menggunakan Regresi Logistik dan K-NN, kemampupuan model dalam memprediksi benar dari data aktual orang yang Overweight lebih baik dengan menggunakan metode Regresi Logistik karena memiliki nilai lebih besar dari pada menggunakan metode K-NN.