Επιλογή μεθόδου: Ποια μέθοδο θα επιλέξετε με βάση τα παραπάνω;

Απάντηση: Η μέθοδος που επιλέχθηκε είναι η γραμμική παλινδρομηση, δεν επιλεχθηκε Random Forest, γιατί η ερώτηση ζητά ρητά ποσοτική εξήγηση της επίδρασης κάθε χαρακτηριστικού (π.χ. “+X€ ανά έτος ηλικίας”), κάτι που δίνεται φυσικά μόνο από τους συντελεστές γραμμικού μοντέλου.

Διερεύνηση του συνόλου δεδομένων (dataset)

Dataset: Medical Cost Personal — kaggle.com/datasets/mirichoi0218/insurance

Δεδομένα 1.338 ατόμων: ηλικία, φύλο, BMI, αριθμός παιδιών, κάπνισμα, περιοχή.

Στόχος της ανάλυσης είναι μία ασφαλιστική εταιρεία θέλει να καταλάβει ποιοι παράγοντες διαμορφώνουν το ετήσιο κόστος ασφάλισης κάθε πελάτη και πόσο συνεισφέρει ο καθένας, ώστε να τιμολογήσει πιο δίκαια νέα συμβόλαια.Ως εξαρτημένη μεταβλητή (target variable) επιλέγεται το charges, δηλαδή το κόστος ασφάλισης. Οι υπόλοιπες μεταβλητές λειτουργούν ως ανεξάρτητες (predictors), οι οποίες χρησιμοποιούνται για να εξηγήσουν και να προβλέψουν.

library(readr)
library(ggplot2)
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
data <- read.csv("insurance.csv")

View(data)
str(data)
## 'data.frame':    1338 obs. of  7 variables:
##  $ age     : int  19 18 28 33 32 31 46 37 37 60 ...
##  $ sex     : chr  "female" "male" "male" "male" ...
##  $ bmi     : num  27.9 33.8 33 22.7 28.9 ...
##  $ children: int  0 1 3 0 0 0 1 3 2 0 ...
##  $ smoker  : chr  "yes" "no" "no" "no" ...
##  $ region  : chr  "southwest" "southeast" "southeast" "northwest" ...
##  $ charges : num  16885 1726 4449 21984 3867 ...
glimpse(data)
## Rows: 1,338
## Columns: 7
## $ age      <int> 19, 18, 28, 33, 32, 31, 46, 37, 37, 60, 25, 62, 23, 56, 27, 1…
## $ sex      <chr> "female", "male", "male", "male", "male", "female", "female",…
## $ bmi      <dbl> 27.900, 33.770, 33.000, 22.705, 28.880, 25.740, 33.440, 27.74…
## $ children <int> 0, 1, 3, 0, 0, 0, 1, 3, 2, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0…
## $ smoker   <chr> "yes", "no", "no", "no", "no", "no", "no", "no", "no", "no", …
## $ region   <chr> "southwest", "southeast", "southeast", "northwest", "northwes…
## $ charges  <dbl> 16884.924, 1725.552, 4449.462, 21984.471, 3866.855, 3756.622,…
summary(data) 
##       age            sex                 bmi           children    
##  Min.   :18.00   Length:1338        Min.   :15.96   Min.   :0.000  
##  1st Qu.:27.00   Class :character   1st Qu.:26.30   1st Qu.:0.000  
##  Median :39.00   Mode  :character   Median :30.40   Median :1.000  
##  Mean   :39.21                      Mean   :30.66   Mean   :1.095  
##  3rd Qu.:51.00                      3rd Qu.:34.69   3rd Qu.:2.000  
##  Max.   :64.00                      Max.   :53.13   Max.   :5.000  
##     smoker             region             charges     
##  Length:1338        Length:1338        Min.   : 1122  
##  Class :character   Class :character   1st Qu.: 4740  
##  Mode  :character   Mode  :character   Median : 9382  
##                                        Mean   :13270  
##                                        3rd Qu.:16640  
##                                        Max.   :63770
# Έλεγχος κενών τιμών (missing values)
missing_table <- data.frame(
Missing_Values = colSums(is.na(data)),
Percentage = (colSums(is.na(data)) / nrow(data)) * 100
)
print(missing_table)
##          Missing_Values Percentage
## age                   0          0
## sex                   0          0
## bmi                   0          0
## children              0          0
## smoker                0          0
## region                0          0
## charges               0          0
set.seed(140)
n <- nrow(data)
train_index <- sample(1:n, size = 0.7 * n)
train <- data[train_index, ]
test <- data[-train_index, ]

nrow(train) 
## [1] 936
nrow(test) 
## [1] 402
# Μετατροπή κατηγορικών σε factors
train$sex <- as.factor(train$sex)
train$smoker <- as.factor(train$smoker)
train$region <- as.factor(train$region)
numeric_data <- train[sapply(train, is.numeric)]

# πίνακα συσχετίσεων (βάζουμε use="complete.obs" για να αγνοήσει τυχόν κενά κελιά NA)
cor_matrix <- cor(numeric_data, use = "complete.obs")

# Ζητάμε να δούμε μόνο τις συσχετίσεις charges, ταξινομημένες
sort(cor_matrix[,"charges"], decreasing = TRUE)
##   charges       age       bmi  children 
## 1.0000000 0.3040064 0.1982437 0.0578012

Δημιουργία (και αξιολόγηση) μοντέλου παλινδρόμησης

# Βασικό μοντέλο

model <- glm(charges ~ age, data = train)
summary(model)
## 
## Call:
## glm(formula = charges ~ age, data = train)
## 
## Coefficients:
##             Estimate Std. Error t value Pr(>|t|)    
## (Intercept)  2849.45    1105.12   2.578   0.0101 *  
## age           261.98      26.86   9.752   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for gaussian family taken to be 133185768)
## 
##     Null deviance: 1.3706e+11  on 935  degrees of freedom
## Residual deviance: 1.2440e+11  on 934  degrees of freedom
## AIC: 20170
## 
## Number of Fisher Scoring iterations: 2
#Scatterplot
ggplot(data, aes(age,charges)) +
      geom_point() + 
      geom_abline(aes(intercept = coef(model)[1], 
slope = coef(model)[2]), colour = "red")

SSE <- sum(model$residuals^2) 
print(SSE)
## [1] 124395507048
RMSE <- sqrt(SSE/nrow(train)) 
print(RMSE)
## [1] 11528.28

Σχολιασμός αποτελεσμάτων: p-value: Έχει αστεράκια (***), που σημαίνει ότι είναι κάτω από 0.05. Άρα η ηλικία είναι στατιστικά σημαντική μεταβλητή.

model2 <- lm(charges ~ age+ sex + bmi + children + smoker + region, data = train)
summary(model2)
## 
## Call:
## lm(formula = charges ~ age + sex + bmi + children + smoker + 
##     region, data = train)
## 
## Residuals:
##      Min       1Q   Median       3Q      Max 
## -11488.1  -2825.5   -867.5   1466.5  30004.8 
## 
## Coefficients:
##                  Estimate Std. Error t value Pr(>|t|)    
## (Intercept)     -11581.45    1150.17 -10.069  < 2e-16 ***
## age                251.94      14.27  17.655  < 2e-16 ***
## sexmale           -473.87     398.76  -1.188  0.23499    
## bmi                337.49      33.77   9.994  < 2e-16 ***
## children           470.28     167.57   2.807  0.00511 ** 
## smokeryes        24146.83     496.25  48.659  < 2e-16 ***
## regionnorthwest   -359.33     560.77  -0.641  0.52183    
## regionsoutheast  -1087.06     568.77  -1.911  0.05628 .  
## regionsouthwest   -920.92     573.44  -1.606  0.10862    
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 6039 on 927 degrees of freedom
## Multiple R-squared:  0.7533, Adjusted R-squared:  0.7512 
## F-statistic: 353.8 on 8 and 927 DF,  p-value: < 2.2e-16

p-value: Έχει αστεράκια (***) το bmi, children και smokers, που σημαίνει ότι είναι κάτω από 0.05.Τα υπόλοιπα δεν ειναι δημαντικες μεταβλητες και τα απορρηπτουμε.

SSE2 <- sum(model2$residuals^2) 
print(SSE2)
## [1] 3.3812e+10
RMSE2 <- sqrt(SSE2/nrow(train)) 
print(RMSE2)
## [1] 6010.319
model3 <- lm(charges ~ age + bmi + children + smoker, data = train)

# Εμφάνιση της σύνοψης
summary(model3)
## 
## Call:
## lm(formula = charges ~ age + bmi + children + smoker, data = train)
## 
## Residuals:
##      Min       1Q   Median       3Q      Max 
## -11984.0  -2826.0   -946.9   1458.4  29278.1 
## 
## Coefficients:
##              Estimate Std. Error t value Pr(>|t|)    
## (Intercept) -11858.84    1103.44 -10.747  < 2e-16 ***
## age            254.31      14.24  17.861  < 2e-16 ***
## bmi            316.56      32.30   9.801  < 2e-16 ***
## children       463.22     167.54   2.765  0.00581 ** 
## smokeryes    24119.04     495.33  48.693  < 2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 6045 on 931 degrees of freedom
## Multiple R-squared:  0.7518, Adjusted R-squared:  0.7507 
## F-statistic: 704.9 on 4 and 931 DF,  p-value: < 2.2e-16
SSE3 <- sum(model3$residuals^2) 
print(SSE3)
## [1] 34023681687
RMSE3 <- sqrt(SSE3/nrow(train)) 
print(RMSE3)
## [1] 6029.103

Εφαρμογή σε νέο σύνολο δεδομένων - Πρόβλεψη

#προβλέψεις
predictions <- predict(model3, newdata = test)
head(predictions)
##         2         4        13        19        23        27 
##  3872.124  3720.751  4879.868 15139.664  3513.371 11470.217
test_errors <- test$charges - predictions

SSE_test <- sum(test_errors^2, na.rm = TRUE)

RMSE_test <- sqrt(SSE_test / nrow(test))

print(paste("Το SSE στα νέα δεδομένα είναι:", SSE_test))
## [1] "Το SSE στα νέα δεδομένα είναι: 15081238070.209"
print(paste("Το RMSE (μέσο σφάλμα σε χρόνια) είναι:", RMSE_test))
## [1] "Το RMSE (μέσο σφάλμα σε χρόνια) είναι: 6124.99123163329"

Διερευνητικές ερωτήσεις:

  1. Πόσο μεταβάλλεται (σε €) το αναμενόμενο ετήσιο κόστος για κάθε επιπλέον έτος ηλικίας, κρατώντας τα υπόλοιπα σταθερά;
# Βγαινουμε στο συμπέρασμα για επιλογή age 

ggplot(data, aes(age, charges)) +
     geom_point() 

#επιδραση υλικιας
coef(model)["age"]
##      age 
## 261.9768

Σχολιασμός αποτελεσμάτων: Για κάθε επιπλέον έτος ηλικίας, το charges αυξάνεται κατά age €

  1. Πόσο ακριβότερο είναι, κατά μέσο όρο, ένα συμβόλαιο καπνιστή έναντι μη καπνιστή με ίδια λοιπά χαρακτηριστικά;
#διαφορα με smokers 
coef(model2)["smokeryes"]
## smokeryes 
##  24146.83

Σχολιασμός αποτελεσμάτων: Αυτό είναι η μέση διαφορά σε € μεταξύ καπνιστή και μη καπνιστή, με ίδια όλα τα άλλα.

  1. Ποιο ποσοστό της μεταβλητότητας του κόστους εξηγείται από τα διαθέσιμα χαρακτηριστικά;
#ποσοστό 
summary(model2)$r.squared
## [1] 0.7533102
summary(model2)$adj.r.squared
## [1] 0.7511813

Σχολιασμός αποτελεσμάτων: Είναι κατα 75%

  1. Υπάρχει ένδειξη ότι η επίδραση του BMI στο κόστος είναι διαφορετική για καπνιστές και μη (αλληλεπίδραση);
#αλληλεπιδραση bpi με smoker
model_int <- lm(charges ~ age + sex + bmi*smoker + children + region, data = data)
summary(model_int)
## 
## Call:
## lm(formula = charges ~ age + sex + bmi * smoker + children + 
##     region, data = data)
## 
## Residuals:
##      Min       1Q   Median       3Q      Max 
## -14580.7  -1857.2  -1360.8   -475.7  30552.4 
## 
## Coefficients:
##                   Estimate Std. Error t value Pr(>|t|)    
## (Intercept)      -2223.454    865.611  -2.569  0.01032 *  
## age                263.620      9.516  27.703  < 2e-16 ***
## sexmale           -500.146    266.518  -1.877  0.06079 .  
## bmi                 23.533     25.601   0.919  0.35814    
## smokeryes       -20415.611   1648.277 -12.386  < 2e-16 ***
## children           516.403    110.179   4.687 3.06e-06 ***
## regionnorthwest   -585.478    380.859  -1.537  0.12447    
## regionsoutheast  -1210.131    382.750  -3.162  0.00160 ** 
## regionsouthwest  -1231.108    382.218  -3.221  0.00131 ** 
## bmi:smokeryes     1443.096     52.647  27.411  < 2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 4846 on 1328 degrees of freedom
## Multiple R-squared:  0.8409, Adjusted R-squared:  0.8398 
## F-statistic:   780 on 9 and 1328 DF,  p-value: < 2.2e-16

Σχολιασμός αποτελεσμάτων: Ο όρος bmi:smokeryes είναι στατιστικά σημαντικός (p < 0.05), τότε ναι, η επίδραση του BMI στο κόστος διαφέρει σημαντικά ανάμεσα σε καπνιστές/μη καπνιστές (τυπικά: πολύ ισχυρότερη θετική επίδραση για καπνιστές).

  1. Να προβλεψετε το κόστος για έναν 45χρονο μη καπνιστή, BMI 28, με 2 παιδιά.
new_data <- data.frame(
  age = 45,
  sex = factor("male", levels = levels(test$sex)),   # ή female, δεν δίνεται
  bmi = 28,
  children = 2,
  smoker = factor("no", levels = levels(test$smoker)),
  region = factor("southeast", levels = levels(test$region))  # default/mode
)
predict(model, newdata = new_data)
##        1 
## 14638.41

Σχολιασμός αποτελεσμάτων:το κόστος είναι 14638.41