About
Berikut beberapa faktor yang mungkin bisa mempengaruhi biaya permi asuransi kesehatan:
age: Usia penerima manfaat.
sex: jenis kelamin female dan male.
bmi: Body mass index (kg / m ^ 2), menggunakan rasio tinggi dan berat idealnya 18.5 - 24.9.
children: Jumlah anak.
smoker: Merokok.
region: Daerah tempat tinggal northeast, southeast, southwest, northwest.
library(ggplot2)
library(dplyr)
library(Hmisc)
library(cowplot)
library(WVPlots)
library(tidyverse)
library(reshape2)
library(plotly)
library(data.table)
library(GGally)
library(tidymodels)
library(car)
library(scales)
library(lmtest)df <- read.csv("insurances.csv")
head(df)#> age sex bmi children smoker region charges
#> 1 19 female 27.900 0 yes southwest 16884.924
#> 2 18 male 33.770 1 no southeast 1725.552
#> 3 28 male 33.000 3 no southeast 4449.462
#> 4 33 male 22.705 0 no northwest 21984.471
#> 5 32 male 28.880 0 no northwest 3866.855
#> 6 31 female 25.740 0 no southeast 3756.622str(df)#> '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 ...df_raw <- df %>%
mutate(sex = factor(sex),
smoker = factor(smoker),
region = factor(region))
df <- df %>%
mutate(sex = factor(sex),
smoker = factor(smoker),
region = factor(region))
str(df_raw)#> 'data.frame': 1338 obs. of 7 variables:
#> $ age : int 19 18 28 33 32 31 46 37 37 60 ...
#> $ sex : Factor w/ 2 levels "female","male": 1 2 2 2 2 1 1 1 2 1 ...
#> $ bmi : num 27.9 33.8 33 22.7 28.9 ...
#> $ children: int 0 1 3 0 0 0 1 3 2 0 ...
#> $ smoker : Factor w/ 2 levels "no","yes": 2 1 1 1 1 1 1 1 1 1 ...
#> $ region : Factor w/ 4 levels "northeast","northwest",..: 4 3 3 2 2 3 3 2 1 2 ...
#> $ charges : num 16885 1726 4449 21984 3867 ...describe(df)#> df
#>
#> 7 Variables 1338 Observations
#> --------------------------------------------------------------------------------
#> age
#> n missing distinct Info Mean Gmd .05 .10
#> 1338 0 47 0.999 39.21 16.21 18 19
#> .25 .50 .75 .90 .95
#> 27 39 51 59 62
#>
#> lowest : 18 19 20 21 22, highest: 60 61 62 63 64
#> --------------------------------------------------------------------------------
#> sex
#> n missing distinct
#> 1338 0 2
#>
#> Value female male
#> Frequency 662 676
#> Proportion 0.495 0.505
#> --------------------------------------------------------------------------------
#> bmi
#> n missing distinct Info Mean Gmd .05 .10
#> 1338 0 548 1 30.66 6.893 21.26 22.99
#> .25 .50 .75 .90 .95
#> 26.30 30.40 34.69 38.62 41.11
#>
#> lowest : 15.960 16.815 17.195 17.290 17.385, highest: 48.070 49.060 50.380 52.580 53.130
#> --------------------------------------------------------------------------------
#> children
#> n missing distinct Info Mean Gmd
#> 1338 0 6 0.899 1.095 1.275
#>
#> lowest : 0 1 2 3 4, highest: 1 2 3 4 5
#>
#> Value 0 1 2 3 4 5
#> Frequency 574 324 240 157 25 18
#> Proportion 0.429 0.242 0.179 0.117 0.019 0.013
#> --------------------------------------------------------------------------------
#> smoker
#> n missing distinct
#> 1338 0 2
#>
#> Value no yes
#> Frequency 1064 274
#> Proportion 0.795 0.205
#> --------------------------------------------------------------------------------
#> region
#> n missing distinct
#> 1338 0 4
#>
#> Value northeast northwest southeast southwest
#> Frequency 324 325 364 325
#> Proportion 0.242 0.243 0.272 0.243
#> --------------------------------------------------------------------------------
#> charges
#> n missing distinct Info Mean Gmd .05 .10
#> 1338 0 1337 1 13270 12301 1758 2347
#> .25 .50 .75 .90 .95
#> 4740 9382 16640 34832 41182
#>
#> lowest : 1121.874 1131.507 1135.941 1136.399 1137.011
#> highest: 55135.402 58571.074 60021.399 62592.873 63770.428
#> --------------------------------------------------------------------------------#Insight:
Age: rata-rata usia adalah 39.21 dengan rentang usia dari 18 hingga 64 tahun.
Sex: terdapat 662 perempuan dan 676 laki-laki dalam sampel tersebut.
BMI: rata-rata bmi adalah 30.66 dan rentangnya berkisar dari 15.96 hingga 53.13.
Children: rata-rata jumlah anak adalah 1.095 dan rentangnya adalah dari 0 hingga 5 anak.
Smoke: terdapat 1064 orang yang tidak merokok dan 274 orang yang merokok dalam sampel tersebut.
Region: terdapat 4 wilayah yaitu northeast, northwest, southeast, dan southwest dengan frekuensi yang hampir sama.
Charges: rata-rata biaya adalah 13270 dengan rentang biaya dari 1121.87 hingga 63770.43
colSums(is.na(df))#> age sex bmi children smoker region charges
#> 0 0 0 0 0 0 0p <- ggplot(df, aes(x = charges)) +
geom_histogram(aes(y=..density..), bins=30, color = "black", fill = "cyan") +
geom_density(color="blue", size=1) +
ggtitle("Distribution of Charges") +
theme_classic() +
xlab("Charges") +
ylab("Density")
ggplotly(p)Distribusi right-skewed, Untuk membuatnya lebih mendekati normal dapat menggunakan skala logaritmik.
library(ggplot2)
q<-ggplot(df, aes(x = log10(charges))) +
geom_density(color = "red", fill = "pink", alpha = 0.5) +
ggtitle("Distribution of Charges (log10 scale)") +
xlab("Log10 of Charges") +
ylab("Density")
ggplotly(q)charges <- df %>%
group_by(region) %>%
summarise(total_charges = sum(charges)) %>%
arrange(desc(total_charges))
ChargesRegion<-ggplot(charges, aes(x = total_charges, y = reorder(region, total_charges))) +
geom_bar(stat = "identity", aes(fill = total_charges)) +
scale_fill_gradient(low = "lightblue", high = "darkblue") +
ggtitle("Total Charges by Region (descending order)") +
xlab("Total Charges") +
ylab("Region")
ggplotly(ChargesRegion)#Inight:
Secara keseluruhan, biaya medis tertinggi berada di Southeast dan yang terendah berada di Wilayah southwest.
RegionSx<-ggplot(df, aes(x = region, y = charges, fill = sex)) +
geom_bar(stat = "identity", position = "dodge") +
scale_fill_manual(values = c("#4BACC6", "#ED7D31")) +
ggtitle("Charges by Region and Sex") +
xlab("Region") +
ylab("Charges")
ggplotly(RegionSx)#Inight:
Dari seluruh region southeast mendapatkan charges tertinggi dengan perempuan sebagai chrages tertinggi.
RegionSmoking <-ggplot(df, aes(x = region, y = charges, fill = smoker)) +
geom_col(position = "dodge") +
scale_fill_manual(values = c("#FEE0D2", "#FB6A4A")) +
ggtitle("Charges by Region and Smoking Status") +
xlab("Region") +
ylab("Charges")
ggplotly(RegionSmoking)#Inight:
Dari seluruh region southeast merupakan prokok terbanyak.
RegionCharger<-ggplot(df, aes(x = region, y = charges, fill = factor(children))) +
geom_col(position = "dodge") +
scale_fill_discrete(name = "Children") +
ggtitle("Charges by Region and Number of Children") +
xlab("Region") +
ylab("Charges")
ggplotly(RegionCharger)#Inight:
Seperti yang dapat dilihat dari grafik diatas, biaya medis tertinggi akibat merokok masih terdapat di wilayah Southeast, namun yang terendah ada di wilayah Northeast. Orang-orang di wilayah Southwest umumnya merokok lebih banyak daripada orang-orang di wilayah Northeast, tetapi orang-orang di wilayah Northeast memiliki biaya yang lebih tinggi berdasarkan jenis kelamin dibandingkan di wilayah Southwest dan Northwest secara keseluruhan. Dan orang-orang yang memiliki anak cenderung memiliki biaya medis yang lebih tinggi secara keseluruhan.
par(mfrow=c(1,3))
ChargesAge<- ggplot(df, aes(x = age, y = charges, color = smoker)) +
geom_point() +
geom_smooth(method = 'lm', se = FALSE) +
labs(title = 'Age vs Charges')
ChargesBmi<-ggplot(df, aes(x = bmi, y = charges, color = smoker)) +
geom_point() +
geom_smooth(method = 'lm', se = FALSE) +
labs(title = 'BMI vs Charges')
ChargesChild<-ggplot(df, aes(x = children, y = charges, color = smoker)) +
geom_point() +
geom_smooth(method = 'lm', se = FALSE) +
labs(title = 'Children vs Charges')
ggplotly(ChargesAge)ggplotly(ChargesBmi)ggplotly(ChargesChild)#Inight:
Merokok memiliki dampak terbesar pada biaya medis, meskipun biaya tersebut meningkat dengan bertambahnya usia, bmi, dan jumlah anak. Selain itu, orang yang memiliki anak cenderung merokok lebih sedikit.
df <- df %>%
mutate(across(c(sex, smoker, region), as.factor),
sex = as.numeric(sex) - 1,
smoker = as.numeric(smoker) - 1)
df$sex <- as.numeric(df$sex)
df$smoker <- as.numeric(df$smoker)
df$region <- as.numeric(df$region)
ggplotly(ggcorr(df, label=TRUE))#Inight:
Dari grafik diatas perokok memiliki korelasi tertinggi terhadap biaya.
n_train <- round(0.8 * nrow(df_raw))
train_indices <- sample(1:nrow(df_raw), n_train)
Data_train <- df_raw[train_indices, ]
Data_test <- df_raw[-train_indices, ]
formula_split <- as.formula("charges ~ age + sex + bmi + children + smoker + region")#model
model_all <- lm(formula_split, data = Data_train)
summary(model_all)#>
#> Call:
#> lm(formula = formula_split, data = Data_train)
#>
#> Residuals:
#> Min 1Q Median 3Q Max
#> -10471 -3026 -1055 1315 24191
#>
#> Coefficients:
#> Estimate Std. Error t value Pr(>|t|)
#> (Intercept) -12221.038 1101.191 -11.098 <0.0000000000000002 ***
#> age 252.578 13.115 19.258 <0.0000000000000002 ***
#> sexmale 1.294 370.679 0.003 0.9972
#> bmi 354.072 31.922 11.092 <0.0000000000000002 ***
#> children 484.077 153.876 3.146 0.0017 **
#> smokeryes 23398.297 464.717 50.350 <0.0000000000000002 ***
#> regionnorthwest -221.464 531.814 -0.416 0.6772
#> regionsoutheast -1168.132 533.854 -2.188 0.0289 *
#> regionsouthwest -802.282 533.315 -1.504 0.1328
#> ---
#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
#>
#> Residual standard error: 6048 on 1061 degrees of freedom
#> Multiple R-squared: 0.7475, Adjusted R-squared: 0.7456
#> F-statistic: 392.6 on 8 and 1061 DF, p-value: < 0.00000000000000022#Inight:
Seperti yang dapat kita lihat, ringkasan dari sebuah model menunjukkan bahwa beberapa variabel tidak signifikan yaitu sex, sementara merokok sepertinya memiliki pengaruh besar pada biaya medis. Melatih model tanpa variabel yang tidak signifikan dan memeriksa apakah kinerjanya dapat ditingkatkan.
#save model r sqr
r_sqr_model1 <- summary(model_all)$r.squared
#save model prediction
predict_model1 <- predict(model_all, Data_test)
#save model residual
residual_model1 <- Data_test$charges - predict_model1
#save model rmse
rmse_model1 <- sqrt(mean(residual_model1^2))formula_2 <- as.formula("charges ~ age+bmi+children+smoker+region")
model_2 <- lm(formula_2, data= Data_train)
summary(model_2)#>
#> Call:
#> lm(formula = formula_2, data = Data_train)
#>
#> Residuals:
#> Min 1Q Median 3Q Max
#> -10470 -3026 -1055 1316 24191
#>
#> Coefficients:
#> Estimate Std. Error t value Pr(>|t|)
#> (Intercept) -12220.56 1092.18 -11.189 < 0.0000000000000002 ***
#> age 252.58 13.11 19.268 < 0.0000000000000002 ***
#> bmi 354.08 31.86 11.112 < 0.0000000000000002 ***
#> children 484.09 153.78 3.148 0.00169 **
#> smokeryes 23398.35 464.20 50.406 < 0.0000000000000002 ***
#> regionnorthwest -221.48 531.54 -0.417 0.67699
#> regionsoutheast -1168.14 533.60 -2.189 0.02880 *
#> regionsouthwest -802.29 533.06 -1.505 0.13260
#> ---
#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
#>
#> Residual standard error: 6045 on 1062 degrees of freedom
#> Multiple R-squared: 0.7475, Adjusted R-squared: 0.7458
#> F-statistic: 449.1 on 7 and 1062 DF, p-value: < 0.00000000000000022#Inight:
Di kedua model, merokok memiliki koefisien positif yang sangat signifikan, menunjukkan bahwa perokok cenderung memiliki biaya medis yang jauh lebih tinggi dibandingkan dengan non-perokok. Usia, BMI, dan memiliki anak juga memiliki koefisien positif yang signifikan, artinya jika variabel-variabel ini meningkat, biaya medis juga akan meningkat.
Variabel region memiliki koefisien yang kurang signifikan, hanya region 3 dan region 4 yang memiliki nilai p mendekati 0,05, menunjukkan hubungan yang lemah dengan biaya medis.
Nilai R-kuadrat yang disesuaikan untuk kedua model sekitar 0,76, menunjukkan bahwa model-model tersebut menjelaskan sekitar 76% variansi pada data. Residual standard error merepresentasikan jumlah variasi rata-rata pada variabel respons yang tidak dijelaskan oleh model. Kedua model memiliki nilai-nilai yang sangat mirip untuk metrik-metrik ini, menunjukkan bahwa mereka dapat dibandingkan dari segi performa.
Data_test$prediction <- predict(model_2, Data_test)
ggplotly(ggplot(Data_test, aes(x = prediction, y = charges)) +
geom_point(color = "green", alpha = 0.7) +
geom_abline(color = "red") +
ggtitle("Prediction vs. Real values"))Data_test$residuals<- Data_test$charges - Data_test$prediction
ggplotly(ggplot(data = Data_test, aes(x = prediction, y = residuals)) +
geom_pointrange(aes(ymin = 0, ymax = residuals), color = "yellow", alpha = 0.7) +
geom_hline(yintercept = 0, linetype = 3, color = "red") +
ggtitle("Residuals vs. Linear model prediction"))ggplotly(ggplot(Data_test, aes(x = residuals)) +
geom_histogram(bins = 15, fill = "red") +
ggtitle("Histogram of residuals"))ggplotly(GainCurvePlot(Data_test, "prediction", "charges", "Model"))#Inight:
Dari grafik diatas model menunjukan error mendekati 0, jadi model sudah baik.
Luffy <- data.frame(age= 55,
bmi= 40,
children= 0,
sex="male",
smoker="yes",
region="southeast")
predict(model_all, Luffy)#> 1
#> 38065.09