Untitled

1 Mục đích nghiên cứu

Bài tiểu luận được xây dựng trên mục đích để tìm hiểu những yếu tố ảnh hưởng đến sự tham gia quỹ hưu trí 401(k) của người lao động Mỹ. Dữ liệu được thu thập từ hơn 9000 cư dân, họ có thu nhập, tình trạng hôn nhân. giới tính, độ tuổi,… đa dạng. Mô hình hồi quy tuyến tính tổng quát được áp dụng để đánh giá định lượng tác động của của biến giải thích lên với biến phụ thuộc định tính p401k (biến thể hiện tham gia quỹ hay không).

2 Mô tả số liệu

Số liệu được thu thập trên 9200 người lao động Mỹ có nghề nghiệp trong các lĩnh vực bất kỳ đến từ các tiểu bang khác nhau. Những thông tin được thu thập gồm:
+ Thu nhập (inc): Số tiền thu nhập trung bình theo giờ.
+ Tình trạng hôn nhân (marr): Đã kết hôn hoặc Chưa kết hôn + Giới tính (male): Gồm hai giới tính Nam, hoặc Nữ.
+ Độ tuổi (age): Số năm tuổi.
+ Số thành viên trong gia đình (fsize).
+ Tài sản tích lũy, tiết kiệm cho đến thời điểm khảo sát (nettffa).
+ Quỹ hưu trí đã tham gia trước đó (pira): Nếu người được khảo sát đã tham gia ít nhất một quỹ hưu trí tại thời điểm khảo sát sẽ được ghi nhận là “Đã tham gia”. “Chưa tham gia” là kết quả được ghi nhận cho những cư dân tại thời điểm khảo sát không tham gia bất kỳ quỹ hưu trí nào.
+ Điều kiện tham gia quỹ hưu trí 401(k) (e401k): Đây là điều kiện tham gia được dựa trên thông tin nhân khẩu được ban hành bởi Cục Quản lý An sinh Xã hội Hoa Kỳ (SSA). Những thông tin cơ bản của người lao động được xét đến là độ tuổi, thời gian làm việc, tiền thuế đã nộp, thơi gian và khoản tiền đã đóng góp cho quỹ. Biến này được ghi nhận ‘Đủ’ hoặc “Không Đủ” cho mỗi quan sát
+ Thực trạng tham gia quỹ của người lao động (p401k): Tham gia hoặc Không Tham Gia

library(DT)

## Warning: package 'DT' was built under R version 4.4.1

library(readxl)

## Warning: package 'readxl' was built under R version 4.4.1

d <- read_excel("C:/users/user/Downloads/k401ksubs.xlsx", sheet = "k401ksubs")
datatable(d)

3 Thống kê Mô tả

3.1 Điều kiện tham gia quỹ

library(ggplot2)

## Warning: package 'ggplot2' was built under R version 4.4.1

tmp <- table(d$e401k, d$p401k)
tmp

##           
##            Không Tham Gia Tham Gia
##   Đủ                 1075     2562
##   Không Đủ           5638        0

ggplot(d, aes(e401k, fill = p401k)) + geom_bar(position = 'dodge')

Một điều hiển nhiên là những người lao động không đủ điều kiện tham gia quỹ thì không tham gia quỹ hưu trí 401k. Những người này chiếm khoảng 60% những người được khảo sát. Có một điểm đáng chú ý ở 40% những người đủ điều kiện tham gia quỹ, số người tham gia nhiều gấp 2.5 lần số người không tham gia. Vì sao một người lao động không đủ điều tham gia quỹ hưu trí? Vì sao một người lao động đủ điều kiện tham gia 401k nhưng lại không tham gia? Mục thống kê mô ta của bài tiểu luận sẽ đi tìm câu trả lởi cho 2 câu hỏi này.

3.2 Giới tính không Ảnh hưởng đến khả năng tham gia quỹ

library(ggplot2)

tmp <- table(d$male, d$p401k)
tmp

##      
##       Không Tham Gia Tham Gia
##   Nam           1414      482
##   Nữ            5299     2080

ggplot(d, aes(male, fill = p401k)) + geom_bar(position = 'dodge')

tmp <- prop.table(tmp)
tmp

##      
##       Không Tham Gia   Tham Gia
##   Nam     0.15245283 0.05196765
##   Nữ      0.57132075 0.22425876

Tử biểu đồ cột này, có thể nhận thấy rằng phần lớn những cư dân được khảo sát là phụ nữ. Số người lao động giới tính nữ là hơn 7000 trên tổng 9275 người (chiếm ba phần tư quan sát). Số người tham gia quỹ hưu trí 401k ở cả hai giới tính đều bé hơn nhiều lần số người không tham gia. Với giới tính nam, tỷ lệ số người tham gia quỹ chỉ bằng 1 phần 3 số người không tham gia quỹ (nghĩa là cứ 4 người nam sẽ có một người tham gia quỹ). Trong khi với giới tính nữ, con số này là 2 phần 5 (tức cứ 7 người sẽ có 2 người tham gia quỹ). Tóm lại tỷ lệ tham gia quỹ 401k ở giới tính nam và nữ lần lượt là xấp xỉ 25% và 28%, không có sự khác biệt rõ ràng giữa tỷ lệ tham gia quỹ của hai giới tính.

Khi lọc ra những quan sát Không Đủ điều kiện tham gia quỹ thì yếu tố Giới tính cũng không ảnh hưởng đến quyết định tham gia quỹ của một người lao động. Ở giới tính nam tỷ lệ số người tham trên số người tham gia quỹ là 0.4394 và ở giới tính nữ là 0.4150.

library(DT)
library(readxl)
library(ggplot2)

data1 <- read_excel("C:/users/user/Downloads/fitered.xlsx", sheet = "Sheet1")

tmp <- table(data1$male, data1$p401k)
tmp

##      
##       Không Tham Gia Tham Gia
##   Nam            211      482
##   Nữ             864     2080

ggplot(d, aes(male, fill = p401k)) + geom_bar(position = 'dodge')

tmp <- prop.table(tmp)
tmp

##      
##       Không Tham Gia   Tham Gia
##   Nam     0.05801485 0.13252681
##   Nữ      0.23755843 0.57189992

3.3 Ảnh hưởng của Thu Nhập

3.3.1 Thu nhập có ảnh hưởng đến điều kiện tham gia quỹ hưu trí

library(ggplot2)
library(gridExtra)

## Warning: package 'gridExtra' was built under R version 4.4.1

library(readxl)

# Đọc dữ liệu từ file Excel
d2 <- read_excel("C:/users/user/Downloads/k401ksubs - Copy.xlsx", sheet = "du")
d3 <- read_excel("C:/users/user/Downloads/k401ksubs - Copy.xlsx", sheet = "kodu")

# Vẽ biểu đồ thứ nhất
plot1 <- ggplot(data = d2, aes(x = rownames, y = inc )) +
  geom_line(color = "green", size = 1) +
  labs(title = "Biểu đồ Thu Nhập với người Đủ điều kiện tham gia quỹ",
       x = "rownames",
       y = "inc")

## Warning: Using `size` aesthetic for lines was deprecated in ggplot2 3.4.0.
## ℹ Please use `linewidth` instead.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.

# Vẽ biểu đồ thứ hai
plot2 <- ggplot(data = d3, aes(x = rownames, y = inc )) +
  geom_line(color = "red", size = 1) +
  labs(title = "Biểu đồ Thu Nhập với người Không Đủ điều kiện tham gia quỹ",
       x = "rownames",
       y = "inc")

# Kết hợp hai biểu đồ vào cùng một hình
grid.arrange(plot1, plot2, ncol = 1)  # ncol = 1 để xếp hai biểu đồ dọc

library(ggplot2)
library(readxl)
library(dplyr)

## Warning: package 'dplyr' was built under R version 4.4.1

## 
## Attaching package: 'dplyr'

## The following object is masked from 'package:gridExtra':
## 
##     combine

## The following objects are masked from 'package:stats':
## 
##     filter, lag

## The following objects are masked from 'package:base':
## 
##     intersect, setdiff, setequal, union

library(gridExtra)

# Đọc dữ liệu từ file Excel
d2 <- read_excel("C:/users/user/Downloads/k401ksubs - Copy.xlsx", sheet = "du")
d3 <- read_excel("C:/users/user/Downloads/k401ksubs - Copy.xlsx", sheet = "kodu")

# Thêm biến nhóm để phân biệt hai nhóm dữ liệu
d2$group <- "Đủ điều kiện tham gia quỹ"
d3$group <- "Không đủ điều kiện tham gia quỹ"

# Tính phân vị cho mỗi quan sát
d2 <- d2 %>% mutate(percentile = percent_rank(inc))
d3 <- d3 %>% mutate(percentile = percent_rank(inc))

# Kết hợp dữ liệu
combined_data <- bind_rows(d2, d3)

# Vẽ biểu đồ kết hợp với phân vị làm trục hoành
plot_combined <- ggplot(data = combined_data, aes(x = percentile, y = inc, color = group, group = group)) +
  geom_line(size = 1) +
  labs(title = "Biểu đồ Thu Nhập của người đủ và không đủ điều kiện tham gia quỹ",
       x = "Phân vị",
       y = "inc") +
  theme_minimal() +
  scale_color_manual(values = c("green", "red"))

# Hiển thị biểu đồ
print(plot_combined)

Những công dân thực hiện khảo sát được đánh số thứ tự phân biệt. Phía trên là biểu đồ thu nhập đã được phân nhóm đủ điều kiện và không đủ điều kiện tham qua quỹ. Dữ liệu thu nhập được dùng đề vẽ biểu đồ đã được sắp xếp lại theo thứ tự thấp đến cao theo thu nhập từ trái qua phải. Theo trực giác, có thể thấy rằng đường biểu đồ thu nhập của nhóm đủ điều kiện tham gia quỹ có cao hơn đường biểu đồ thu nhập của nhóm không đủ điều kiện tham gia quỹ. Ví dụ ở quan sát ở tứ phân vị thứ nhất, nhóm đủ điều kiện có thu nhập trên 25 đô la, còn nhóm không đủ điều kiện có thu nhập dưới 25 đô la. Chênh lệch này rõ rệt ở trung vị và tứ phân vị thứ ba. Ở quan sát thứ 1800, nhóm đủ điều kiện có thu nhập gần 50 đô la, trong khi ở quan sát 2800 nhóm không đủ điều kiện có thu nhập dưới 30 đô la. Ở tứ phân vị thứ 3, nhóm đủ điều kiện có thu nhập 63 đô trong khi nhóm không đủ điều kiện có thu nhập xấp xỉ 48 đô (thấp hơn 24% ). Về mặt lo-gich, vì điều kiện tham gia quỹ có xét đến yếu tố thu nhập, nên thu nhập có thể tác động thuận chiều lên khả năng đủ điều kiện tham gia quỹ của một người. Số liệu được thu thập ủng hộ lập luận này.

3.3.2 Trong nhóm người đủ điều kiện tham gia quỹ 401k, yếu tố thu nhập có ảnh hưởng quyết định tham gia quỹ.

library(ggplot2)
library(gridExtra)
library(readxl)

# Đọc dữ liệu từ file Excel
d4 <- read_excel("C:/users/user/Downloads/fitered.xlsx", sheet = "Sheet3")
d5 <- read_excel("C:/users/user/Downloads/fitered.xlsx", sheet = "Sheet2")

# Vẽ biểu đồ thứ nhất
plot1 <- ggplot(data = d4, aes(x = rownames, y = inc )) +
  geom_line(color = "green", size = 1) +
  labs(title = "Biểu đồ Thu Nhập của người tham gia quỹ",
       x = "rownames",
       y = "inc")

# Vẽ biểu đồ thứ hai
plot2 <- ggplot(data = d5, aes(x = rownames, y = inc )) +
  geom_line(color = "red", size = 1) +
  labs(title = "Biểu đồ Thu Nhập của người Không tham gia quỹ",
       x = "rownames",
       y = "inc")

# Kết hợp hai biểu đồ vào cùng một hình
grid.arrange(plot1, plot2, ncol = 1)  # ncol = 1 để xếp hai biểu đồ dọc

library(ggplot2)
library(readxl)
library(dplyr)

# Đọc dữ liệu từ file Excel
d4 <- read_excel("C:/users/user/Downloads/fitered.xlsx", sheet = "Sheet3")
d5 <- read_excel("C:/users/user/Downloads/fitered.xlsx", sheet = "Sheet4")

# Thêm biến nhóm để phân biệt hai nhóm dữ liệu
d4$group <- "Tham gia quỹ"
d5$group <- "Không tham gia quỹ"

# Tính phân vị cho mỗi quan sát
d4 <- d4 %>% mutate(percentile = percent_rank(inc))
d5 <- d5 %>% mutate(percentile = percent_rank(inc))

# Kết hợp dữ liệu
combined_data <- bind_rows(d4, d5)

# Vẽ biểu đồ kết hợp với phân vị làm trục hoành
ggplot(data = combined_data, aes(x = percentile, y = inc, color = group, group = group)) +
  geom_line(size = 1) +
  labs(title = "Biểu đồ Thu Nhập của người tham gia và không tham gia quỹ",
       x = "Phân vị",
       y = "inc") +
  theme_minimal() +
  scale_color_manual(values = c("green", "red"))

Một biểu hiện tương tự khi khảo sát thu nhập bằng biểu đồ phân vị của nhóm người đã đủ điều kiện tham gia quỹ. Biểu đồ trên thể hiện, trong nhóm người đủ điều kiện tham qua quỹ, người Tham gia quỹ sẽ có thu nhập nhỉnh hơn người không tham gia quỹ. Tuy nhiên, khoảng cách thu nhập (thể hiện bởi khoảng cách giữa 2 đường xanh, đỏ) ở biểu đồ tham gia quỹ thấp hơn khoảng cách ở biểu đồ điều kiện tham gia quỹ. Điều này hàm ý rằng Tác động của thu nhập đến điều kiện tham gia quỹ lớn hơn tác động của nó đến quyết định tham gia quỹ.

3.4 Tình trạng hôn nhân

3.4.1 Tình trạng hôn nhân có tác động đến điều kiện tham gia quỹ hưu trí 401k

library(ggplot2)
library(DescTools)
library(epitools)

tmp <- table(d$marr, d$e401k)
tmp

##               
##                  Đủ Không Đủ
##   Chưa Kết Hôn 1174     2271
##   Đã Kết Hôn   2463     3367

addmargins(tmp)

##               
##                  Đủ Không Đủ  Sum
##   Chưa Kết Hôn 1174     2271 3445
##   Đã Kết Hôn   2463     3367 5830
##   Sum          3637     5638 9275

RelRisk(tmp)

## [1] 0.8066461

ggplot(d, aes(marr, fill = e401k)) + geom_bar(position = 'dodge')

chisq.test(tmp)

## 
##  Pearson's Chi-squared test with Yates' continuity correction
## 
## data:  tmp
## X-squared = 60.276, df = 1, p-value = 8.246e-15

Theo số liệu, nếu một người đã kết hôn, tỷ lệ anh ta (chị ta) đủ điều kiện tham gia quỹ là 42%. Nếu chưa kết hôn, tỷ lệ đủ điều kiện tham gia quỹ là 34%. Những người đủ điều kiện tham gia quỹ cũng có tỷ lệ kết hôn cao hơn những người không đủ điều kiện tham gia (67% so với 59%). Về mặt thống kê mô tả, có thể nói rằng một người đã kết hôn sẽ có khả năng đủ điều kiện tham gia quỹ cao hơn những người chưa kết hôn. Relative Risk cho ta biết rằng nếu một người chưa kết hôn, tỷ lệ anh(chị) ta tham gia quỹ sẽ thấp hơn gần 20% so với người đã kết hôn.
Khi sử dụng thống kê suy diễn. Với kiểm định Chi-bình phương cho tính độc lập của hai biến marr và e401k (giả thiết không: marr và e401k là độc lập), do p-value của kiểm định gần bằng 0, có thể bác bỏ giả thiết không và kết luận marr và e401k có liên quan với nhau.

3.4.2 Tình trạng hôn nhân có tác động đến quyết định tham gia quỹ hưu trí 401k

library(DT)
library(readxl)
library(ggplot2)

data1 <- read_excel("C:/users/user/Downloads/fitered.xlsx", sheet = "Sheet2")

tmp <- table(data1$marr, data1$p401k)
tmp

##               
##                Không Tham Gia Tham Gia
##   Chưa Kết Hôn            394      780
##   Đã Kết Hôn              681     1782

addmargins(tmp)

##               
##                Không Tham Gia Tham Gia  Sum
##   Chưa Kết Hôn            394      780 1174
##   Đã Kết Hôn              681     1782 2463
##   Sum                    1075     2562 3637

RelRisk(tmp)

## [1] 1.213795

ggplot(data1, aes(marr, fill = p401k)) + geom_bar(position = 'dodge')

chisq.test(tmp)

## 
##  Pearson's Chi-squared test with Yates' continuity correction
## 
## data:  tmp
## X-squared = 13.06, df = 1, p-value = 0.0003016

Trong nhóm người đủ điều kiện tham gia quỹ, tỷ lệ tham gia quỹ 401k ở nhóm người kết hôn cao hơn tỷ lệ này ở nhóm người chưa kết hơn (72% so với 66%). Những người tham gia quỹ cũng có tỷ lệ đã kết hôn cao hơn những người không tham gia quỹ (70% so với 63%). Quan sát này làm vững thêm luận điểm rằng những người đã kết hôn sẽ làm tăng khả năng người đó tham gia quỹ hưu trí 401k. Relative Risk cho ta biết rằng nếu một người đã kết hôn, tỷ lệ anh(chị) ta tham gia quỹ sẽ cao hơn 21% so với người chưa kết hôn.
Khi sử dụng thống kê suy diễn. Với kiểm định Chi-bình phương cho tính độc lập của hai biến marr và p401k (giả thiết không: marr và 401k là độc lập), do p-value của kiểm định gần bằng 0, có thể bác bỏ giả thiết không và kết luận marr và e401k có liên quan với nhau.

3.5 Độ tuổi

Có khả năng là một người có độ tuổi càng cao thì khả năng tham gia của người đó càng thấp. Quỹ hưu trí được lập ra cho những người lao động sẽ có khả năng lao động tạo ra giá trị kinh tế trong tương lai cho đất nước. Hơn nữa, thời gian lao động, khoản tiền đóng góp quỹ, tiền thuế đóng góp trong tương lai là những yếu tố để xét điều kiện tham gia quỹ của một người thì tương quan nghịch với độ tuổi của người đó.

library(ggplot2)
library(gridExtra)
library(readxl)

# Đọc dữ liệu từ file Excel
d6 <- read_excel("C:/users/user/Downloads/k401ksubs - Co.xlsx", sheet = "e2")
d7 <- read_excel("C:/users/user/Downloads/k401ksubs - Co.xlsx", sheet = "e3")

# Vẽ biểu đồ thứ nhất
plot1 <- ggplot(data = d6, aes(x = rownames, y = age )) +
  geom_line(color = "green", size = 1) +
  labs(title = "Biểu đồ Độ tuổi của người đủ điều kiện tham gia quỹ",
       x = "rownames",
       y = "age")

# Vẽ biểu đồ thứ hai
plot2 <- ggplot(data = d7, aes(x = rownames, y = age )) +
  geom_line(color = "red", size = 1) +
  labs(title = "Biểu đồ Độ tuổi của người không đủ điều kiện tham gia quỹ",
       x = "rownames",
       y = "age")

# Kết hợp hai biểu đồ vào cùng một hình
grid.arrange(plot1, plot2, ncol = 1)  # ncol = 1 để xếp hai biểu đồ dọc

# Thêm biến nhóm để phân biệt hai nhóm dữ liệu
d6$group <- "Đủ điều kiện tham gia quỹ"
d7$group <- "Không đủ điều Tham gia quỹ"

# Tính phân vị cho mỗi quan sát
d6 <- d6 %>% mutate(percentile = percent_rank(age))
d7 <- d7 %>% mutate(percentile = percent_rank(age))

# Kết hợp dữ liệu
combined_data <- bind_rows(d6, d7)

# Vẽ biểu đồ kết hợp với phân vị làm trục hoành
plot_combined <- ggplot(data = combined_data, aes(x = percentile, y = age, color = group, group = group)) +
  geom_line(size = 1) +
  labs(title = "Biểu đồ Độ tuổi của người đủ điều kiện và không đủ tham gia quỹ",
       x = "Phân vị",
       y = "Độ tuổi") +
  theme_minimal() +
  scale_color_manual(values = c("green", "red"))

# Hiển thị biểu đồ
print(plot_combined)

2 đường biểu đồ dốc lên nhẹ ở độ tuổi trên 50. Điều này có nghĩa là những người trên 50 đến 60 tuồi đủ điều kiện tham gia quỹ và tham gia quỹ có ít hơn những người thuộc khoảng tuổi 30 đến 40 tuổi, hay 40 đến 50 tuổi. Ở trước tuổi 47, nhóm người đủ điều kiện tham gia quỹ có độ tuổi trung bình cao hơn nhóm người không đủ điều kiện. Tuy nhiên sau tuổi 47, nhóm người đủ điều kiện tham gia quỹ có độ tuổi trung bình thấp hơn nhóm người không đủ điều kiện tham gia quỹ.

library(ggplot2)
library(gridExtra)
library(readxl)

# Đọc dữ liệu từ file Excel
d8 <- read_excel("C:/users/user/Downloads/fitered.xlsx", sheet = "Sheet5")
d9 <- read_excel("C:/users/user/Downloads/fitered.xlsx", sheet = "Sheet6")

# Vẽ biểu đồ thứ nhất
plot1 <- ggplot(data = d8, aes(x = rownames, y = age )) +
  geom_line(color = "green", size = 1) +
  labs(title = "Biểu đồ Độ tuổi của người tham gia quỹ",
       x = "rownames",
       y = "age")

# Vẽ biểu đồ thứ hai
plot2 <- ggplot(data = d9, aes(x = rownames, y = age )) +
  geom_line(color = "red", size = 1) +
  labs(title = "Biểu đồ Độ tuổi của người Không tham gia quỹ",
       x = "rownames",
       y = "age")

# Kết hợp hai biểu đồ vào cùng một hình
grid.arrange(plot1, plot2, ncol = 1)  # ncol = 1 để xếp hai biểu đồ dọc

library(ggplot2)
library(readxl)
library(dplyr)

# Đọc dữ liệu từ file Excel
d8 <- read_excel("C:/users/user/Downloads/fitered.xlsx", sheet = "Sheet5")
d9 <- read_excel("C:/users/user/Downloads/fitered.xlsx", sheet = "Sheet6")

# Thêm biến nhóm để phân biệt hai nhóm dữ liệu
d8$group <- "Tham gia quỹ"
d9$group <- "Không tham gia quỹ"

# Tính phân vị cho mỗi quan sát
d8 <- d8 %>% mutate(percentile = percent_rank(age))
d9 <- d9 %>% mutate(percentile = percent_rank(age))

# Kết hợp dữ liệu
combined_data <- bind_rows(d8, d9)

# Vẽ biểu đồ kết hợp với phân vị làm trục hoành
ggplot(data = combined_data, aes(x = percentile, y = age, color = group, group = group)) +
  geom_line(size = 1) +
  labs(title = "Biểu đồ Độ Tuổi của người tham gia và không tham gia quỹ",
       x = "Phân vị",
       y = "inc") +
  theme_minimal() +
  scale_color_manual(values = c("red", "green"))

Trong nhóm người đủ điều kiện tham gia quỹ, độ tuổi của một người lao động không ảnh hưởng đến quyết định tham gia quỹ của người đó.

3.5 Số thành viên trong gia đình

library(ggplot2)
library(gridExtra)
library(readxl)

# Đọc dữ liệu từ file Excel
d10 <- read_excel("C:/users/user/Downloads/k401ksubs - C.xlsx", sheet = "e2")
d11 <- read_excel("C:/users/user/Downloads/k401ksubs - C.xlsx", sheet = "e3")

# Vẽ biểu đồ thứ nhất
plot1 <- ggplot(data = d10, aes(x = rownames, y = fsize )) +
  geom_line(color = "green", size = 1) +
  labs(title = "Biểu đồ số thành viên gia đình của người đủ điều kiện tham gia quỹ",
       x = "rownames",
       y = "fsize")

# Vẽ biểu đồ thứ hai
plot2 <- ggplot(data = d11, aes(x = rownames, y = fsize )) +
  geom_line(color = "red", size = 1) +
  labs(title = "Biểu đồ Số thành viên gia đình của người không đủ điều kiện tham gia quỹ",
       x = "rownames",
       y = "fsize")

# Kết hợp hai biểu đồ vào cùng một hình
grid.arrange(plot1, plot2, ncol = 1)  # ncol = 1 để xếp hai biểu đồ dọc

# Thêm biến nhóm để phân biệt hai nhóm dữ liệu
d10$group <- "Đủ điều kiện tham gia quỹ"
d11$group <- "Không đủ điều kiện tham gia quỹ"

# Tính phân vị cho mỗi quan sát
d10 <- d10 %>% mutate(percentile = percent_rank(fsize))
d11 <- d11 %>% mutate(percentile = percent_rank(fsize))

# Kết hợp dữ liệu
combined_data <- bind_rows(d10, d11)

# Vẽ biểu đồ kết hợp với phân vị làm trục hoành
plot_combined <- ggplot(data = combined_data, aes(x = percentile, y = fsize, color = group, group = group)) +
  geom_line(size = 1) +
  labs(title = "Biểu đồ số thành viên gia đình của người đủ và không đủ điều kiện tham gia quỹ",
       x = "Phân vị",
       y = "Số thành viên gia đình") +
  theme_minimal() +
  scale_color_manual(values = c("green", "red"))

# Hiển thị biểu đồ
print(plot_combined)

Số thành viên trong gia đình phân phối đồng đều và tương tự nhau ở cả 2 nhóm người đủ và không đủ điều kiện tham gia quỹ hưu trí.
Biểu hiện tương tự cũng được phát hiện khi quan sát số thành viên trong gia đình của nhóm người tham gia quỹ và không tham gia quỹ. Như vậy yếu tố số thành viên trong gia đình không tác động đến điều kiện và quyết định tham gia quỹ hưu trí của một người lao động Mỹ.

library(ggplot2)
library(gridExtra)
library(readxl)

# Đọc dữ liệu từ file Excel
d12 <- read_excel("C:/users/user/Downloads/fitered.xlsx", sheet = "Sheet7")
d13 <- read_excel("C:/users/user/Downloads/fitered.xlsx", sheet = "Sheet8")

# Vẽ biểu đồ thứ nhất
plot1 <- ggplot(data = d12, aes(x = rownames, y = fsize )) +
  geom_line(color = "green", size = 1) +
  labs(title = "Biểu đồ số thành viên gia đình của người tham gia quỹ",
       x = "rownames",
       y = "fsize")

# Vẽ biểu đồ thứ hai
plot2 <- ggplot(data = d13, aes(x = rownames, y = fsize )) +
  geom_line(color = "red", size = 1) +
  labs(title = "Biểu đồ Số thành viên gia đình của người tham gia quỹ",
       x = "rownames",
       y = "fsize")

# Kết hợp hai biểu đồ vào cùng một hình
grid.arrange(plot1, plot2, ncol = 1)  # ncol = 1 để xếp hai biểu đồ dọc

# Thêm biến nhóm để phân biệt hai nhóm dữ liệu
d12$group <- "tham gia quỹ"
d13$group <- "Không tham gia quỹ"

# Tính phân vị cho mỗi quan sát
d12 <- d12 %>% mutate(percentile = percent_rank(fsize))
d13 <- d13 %>% mutate(percentile = percent_rank(fsize))

# Kết hợp dữ liệu
combined_data <- bind_rows(d12, d13)

# Vẽ biểu đồ kết hợp với phân vị làm trục hoành
plot_combined <- ggplot(data = combined_data, aes(x = percentile, y = fsize, color = group, group = group)) +
  geom_line(size = 1) +
  labs(title = "Biểu đồ số thành viên gia đình của người tham gia và không tham gia quỹ",
       x = "Phân vị",
       y = "Số thành viên gia đình") +
  theme_minimal() +
  scale_color_manual(values = c("green", "red"))

# Hiển thị biểu đồ
print(plot_combined)

3.6 Tài sản tiết kiệm, tích lũy

library(ggplot2)
library(gridExtra)
library(readxl)

# Đọc dữ liệu từ file Excel
d14 <- read_excel("C:/users/user/Downloads/k401ksubs - D.xlsx", sheet = "e2")
d15 <- read_excel("C:/users/user/Downloads/k401ksubs - D.xlsx", sheet = "e3")

# Vẽ biểu đồ thứ nhất
plot1 <- ggplot(data = d14, aes(x = rownames, y = nettfa )) +
  geom_line(color = "green", size = 1) +
  labs(title = "Biểu đồ tài sản của nhóm người đủ điều kiện tham gia quỹ",
       x = "rownames",
       y = "nettfa")

# Vẽ biểu đồ thứ hai
plot2 <- ggplot(data = d15, aes(x = rownames, y = nettfa )) +
  geom_line(color = "red", size = 1) +
  labs(title = "Biểu đồ tài sản của nhóm người không đủ điều kiện tham gia quỹ",
       x = "rownames",
       y = "nettfa")

# Kết hợp hai biểu đồ vào cùng một hình
grid.arrange(plot1, plot2, ncol = 1)  # ncol = 1 để xếp hai biểu đồ dọc

# Thêm biến nhóm để phân biệt hai nhóm dữ liệu
d14$group <- "Đủ điều kiện tham gia quỹ"
d15$group <- "Không đủ điều kiện tham gia quỹ"

# Tính phân vị cho mỗi quan sát
d14 <- d14 %>% mutate(percentile = percent_rank(nettfa))
d15 <- d15 %>% mutate(percentile = percent_rank(nettfa))

# Kết hợp dữ liệu
combined_data <- bind_rows(d14, d15)

# Vẽ biểu đồ kết hợp với phân vị làm trục hoành
plot_combined <- ggplot(data = combined_data, aes(x = percentile, y = nettfa, color = group, group = group)) +
  geom_line(size = 1) +
  labs(title = "Biểu đồ tài sản của nhóm người đủ và không đủ điều kiện tham gia quỹ",
       x = "Phân vị",
       y = "Tài sản (nettfa)") +
  theme_minimal() +
  scale_color_manual(values = c("green", "red"))

# Hiển thị biểu đồ
print(plot_combined)

Không có sự khác biệt lớn về tài sản của nhóm người tham gia quỹ và nhóm người không tham quỹ trước tứ phân vị quan sát thứ nhất. Nhưng ở trung vị và tứ phân vị thứ 3, sự khác biệt là rõ ràng. Ở quan sát trung vị, người đủ tham gia quỹ có tài sản khoảng 12 nghìn đô, trong khi người không tham gia quỹ có tài sản gần bằng không. Ở quan sát tứ phân vị thứ 3, người đủ tham gia quỹ có tài sản khoảng 36 nghìn đô, trong khi người không tham gia quỹ có tài sản chỉ khoảng 6 nghìn đô (bằng 1 phần 6 nhóm tham gia quỹ).

library(ggplot2)
library(gridExtra)
library(readxl)

# Đọc dữ liệu từ file Excel
d16 <- read_excel("C:/users/user/Downloads/fitered.xlsx", sheet = "Sheet9")
d17 <- read_excel("C:/users/user/Downloads/fitered.xlsx", sheet = "Sheet10")

# Vẽ biểu đồ thứ nhất
plot1 <- ggplot(data = d16, aes(x = rownames, y = nettfa )) +
  geom_line(color = "green", size = 1) +
  labs(title = "Biểu đồ tài sản của nhóm người tham gia quỹ",
       x = "rownames",
       y = "nettfa")

# Vẽ biểu đồ thứ hai
plot2 <- ggplot(data = d17, aes(x = rownames, y = nettfa )) +
  geom_line(color = "red", size = 1) +
  labs(title = "Biểu đồ tài sản của nhóm người không tham gia quỹ",
       x = "rownames",
       y = "nettfa")

# Kết hợp hai biểu đồ vào cùng một hình
grid.arrange(plot1, plot2, ncol = 1)  # ncol = 1 để xếp hai biểu đồ dọc

# Thêm biến nhóm để phân biệt hai nhóm dữ liệu
d16$group <- "Tham gia quỹ"
d17$group <- "Không tham gia quỹ"

# Tính phân vị cho mỗi quan sát
d16 <- d16 %>% mutate(percentile = percent_rank(nettfa))
d17 <- d17 %>% mutate(percentile = percent_rank(nettfa))

# Kết hợp dữ liệu
combined_data <- bind_rows(d16, d17)

# Vẽ biểu đồ kết hợp với phân vị làm trục hoành
plot_combined <- ggplot(data = combined_data, aes(x = percentile, y = nettfa, color = group, group = group)) +
  geom_line(size = 1) +
  labs(title = "Biểu đồ tài sản của nhóm người tham gia và tham gia quỹ",
       x = "Phân vị",
       y = "Tài sản (nettfa)") +
  theme_minimal() +
  scale_color_manual(values = c("red", "green"))

# Hiển thị biểu đồ
print(plot_combined)

Trong nhóm người đủ điều kiện tham gia quỹ, nhóm người tham gia quỹ cũng có tài sản tích lũy trung bình cao hơn những người không tham gia quỹ hưu trí 401(k). Ở quan sát trung vị, trung bình người tham quỹ có tài sản tích lớn hơn khoảng 9000 đô la Mỹ so với người không tham gia quỹ. Con số chênh lệch này lớn lên ở mức xấp xỉ 12 nghìn đô ở quan sát tứ phân vị ba.
Như vậy tài sản tích lũy sẽ tác động thuận chiểu lên cả tỷ lệ đủ điều kiện tham gia và quyết định tham gia quỹ hưu trí 401(k).

3.7 Quỹ hưu trí trước đó đã tham gia

library(DT)
library(readxl)
library(ggplot2)

datan <- read_excel("C:/users/user/Downloads/ne2.xlsx", sheet = "ne2")

tmp <- table(datan$pira, datan$e401k)
tmp

##                
##                   Đủ Không Đủ
##   Chưa tham gia 2478     4438
##   Đã tham gia   1159     1200

addmargins(tmp)

##                
##                   Đủ Không Đủ  Sum
##   Chưa tham gia 2478     4438 6916
##   Đã tham gia   1159     1200 2359
##   Sum           3637     5638 9275

RelRisk(tmp)

## [1] 0.7292742

ggplot(datan, aes(pira, fill = e401k)) + geom_bar(position = 'dodge')

chisq.test(tmp)

## 
##  Pearson's Chi-squared test with Yates' continuity correction
## 
## data:  tmp
## X-squared = 130, df = 1, p-value < 2.2e-16

Những người lao động Mỹ đã từng tham gia ít nhất một quỹ hưu trí trước đó có tỷ lệ đủ điều kiện tham gia 401k cao hơn nhóm người chưa từng tham gia. Tỷ lệ đủ điều kiện tham gia quỹ 401k ở nhóm ngườiđã từng tham gia ít nhất một quỹ hưu trí trước đó là hơn 50% trong khi tỷ lệ này ở nhóm người chưa từng tham gia quỹ hưu trí trước đó là 35%. Kiểm định chi-bình phương cho tính độc lập có p-value gần bằng 0, vậy pira và e401k có liên hệ với nhau

library(DT)
library(readxl)
library(ggplot2)

data1 <- read_excel("C:/users/user/Downloads/fitered.xlsx", sheet = "Sheet1")

tmp <- table(data1$pira, data1$p401k)
tmp

##                
##                 Không Tham Gia Tham Gia
##   Chưa Tham Gia            844     1634
##   Đã Tham Gia              231      928

addmargins(tmp)

##                
##                 Không Tham Gia Tham Gia  Sum
##   Chưa Tham Gia            844     1634 2478
##   Đã Tham Gia              231      928 1159
##   Sum                     1075     2562 3637

RelRisk(tmp)

## [1] 1.708884

ggplot(data1, aes(pira, fill = p401k)) + geom_bar(position = 'dodge')

chisq.test(tmp)

## 
##  Pearson's Chi-squared test with Yates' continuity correction
## 
## data:  tmp
## X-squared = 75.032, df = 1, p-value < 2.2e-16

Biểu đồ thể hiện rõ tỷ lệ tham gia quỹ hưu trí 401(k) của nhóm người đã và chưa từng tham gia quỹ hưu trí nào trước đó. Theo dữ liệu, nếu một người lao động đã tham gia ít nhất một quỹ hưu trí trước đó thì tỷ lệ anh ta tham gia quỹ hưu trí 401(k) là 80%. Nhưng nếu anh ta chưa tham gia một quỹ hưu trí nào trước đó thì con số tỷ lệ này lên chỉ là 65%. Relative Risk cho ta biết nếu một người đã tham quỹ hưu trí nào trước đó, tỷ lệ anh ta tham gia 401(k) sẽ cao hơn 70%. Kiểm định chi-bình phương cho tính độc lập có p-value gần bằng 0, vậy pira và p401k có liên hệ với nhau

3.8 Kết luận từ thống kê mô tả

Từ thống kê mô tả ở những phân tích trước đó, có thể nói rằng những yếu tố tác động đến điều kiện tham gia quỹ 401(k) của một người lao động Mỹ là Thu nhập, Tình trạng hôn nhân, Tình trạng tham gia Quỹ hưu trí trước đó và Tài sản tích lũy của người đó. Với nhóm người đủ điều kiện tham gia quỹ hưu trí 401(k), các yếu tố tác động đến quyết định tham gia quỹ của họ là Thu nhập, Tình trạng hôn nhân, Tài sản tích lũy và Tình trạng tham gia Quỹ hưu trí trước đó. Trong một số nghiên cứu và khảo sát này, người đã tham gia một quỹ hưu trí có xu hướng tham gia thêm quỹ 401(k) có thể do lợi ích của việc đa dạng hóa danh mục tiết kiệm, đầu tư và khả năng tài chính.

4 PHÂN TÍCH HỒI QUY

Trong phần 3, chúng ta biết được những biến có tác động đến điều kiện tham gia quỹ và quyết định tham gia quỹ 401(k) của người lao động Mỹ. Trong phần 4, mục tiêu của tiểu luận là tìm biến giải thích và sử dụng mô hình hồi quy phù hợp để kết luận định lượng liệu nếu một người có thu nhập thay đổ thì xác suất anh ta đủ điều kiện tham gia quỹ hay tham gia quỹ hưu trí 401(k) sẽ thay đổi như thế nào.

4.1 Mô hình logit

4.1.1 Phân tích e401k

dd <- read_excel("C:/users/user/Downloads/k401ksubs1.xlsx", sheet = "k401ksubs")
fitted <- glm(factor(e401k) ~ inc + factor(marr) + nettfa + factor(pira) , family = binomial(link = 'logit'), data = dd)

summary(fitted)

## 
## Call:
## glm(formula = factor(e401k) ~ inc + factor(marr) + nettfa + factor(pira), 
##     family = binomial(link = "logit"), data = dd)
## 
## Coefficients:
##                 Estimate Std. Error z value Pr(>|z|)    
## (Intercept)   -1.3442195  0.0484071 -27.769  < 2e-16 ***
## inc            0.0226405  0.0011778  19.223  < 2e-16 ***
## factor(marr)1 -0.0745137  0.0495459  -1.504    0.133    
## nettfa         0.0026283  0.0005563   4.724 2.31e-06 ***
## factor(pira)1  0.0187567  0.0567628   0.330    0.741    
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 12423  on 9274  degrees of freedom
## Residual deviance: 11709  on 9270  degrees of freedom
## AIC: 11719
## 
## Number of Fisher Scoring iterations: 4

# Dự báo xác suất trên cùng dữ liệu
predicted_probabilities <- predict(fitted, type = "response")

# Thêm dự báo vào dataset gốc
dd$predicted_probabilities <- predicted_probabilities

# Xem dataset với dự báo
head(dd)

Kết quả từ mô hình logit như sau:
log(odds)= -1.3442 + 0.0226inc + 0.0026nettfa + 0.0187pira - 0.074marr

4.1.2 Phân tích p401k

library(readxl)
dt <- read_excel("C:/users/user/Downloads/ne.xlsx", sheet = "Sheet1")
fitted <- glm(factor(p401k) ~ inc + nettfa  + factor(pira) + factor(marr), family = binomial(link = 'logit'), data = dt)

summary(fitted)

## 
## Call:
## glm(formula = factor(p401k) ~ inc + nettfa + factor(pira) + factor(marr), 
##     family = binomial(link = "logit"), data = dt)
## 
## Coefficients:
##               Estimate Std. Error z value Pr(>|z|)    
## (Intercept)   0.287120   0.085902   3.342 0.000831 ***
## inc           0.004993   0.002000   2.496 0.012561 *  
## nettfa        0.012897   0.001505   8.567  < 2e-16 ***
## factor(pira)1 0.177222   0.096814   1.831 0.067168 .  
## factor(marr)1 0.060959   0.084845   0.718 0.472465    
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 4415.8  on 3636  degrees of freedom
## Residual deviance: 4184.9  on 3632  degrees of freedom
## AIC: 4194.9
## 
## Number of Fisher Scoring iterations: 5

# Dự báo xác suất trên cùng dữ liệu
predicted_probabilities <- predict(fitted, type = "response")

# Thêm dự báo vào dataset gốc
dt$predicted_probabilities <- predicted_probabilities

# Xem dataset với dự báo
head(dt)

Kết quả từ mô hình logit như sau:
log(odds) = 0.2871 + 0.0050inc + 0.0129nettfa + 0.1772pira + 0.0848marr

4.2 Mô hình probit

4.2.1 Phân tích e401k

library(readxl)
dd <- read_excel("C:/users/user/Downloads/k401ksubs1.xlsx", sheet = "k401ksubs")
fitted_probit <- glm(factor(e401k) ~ inc + factor(marr) + nettfa + factor(pira), family = binomial(link = 'probit'), data = dd)

summary(fitted)

## 
## Call:
## glm(formula = factor(p401k) ~ inc + nettfa + factor(pira) + factor(marr), 
##     family = binomial(link = "logit"), data = dt)
## 
## Coefficients:
##               Estimate Std. Error z value Pr(>|z|)    
## (Intercept)   0.287120   0.085902   3.342 0.000831 ***
## inc           0.004993   0.002000   2.496 0.012561 *  
## nettfa        0.012897   0.001505   8.567  < 2e-16 ***
## factor(pira)1 0.177222   0.096814   1.831 0.067168 .  
## factor(marr)1 0.060959   0.084845   0.718 0.472465    
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 4415.8  on 3636  degrees of freedom
## Residual deviance: 4184.9  on 3632  degrees of freedom
## AIC: 4194.9
## 
## Number of Fisher Scoring iterations: 5

# Dự báo xác suất trên cùng dữ liệu
predicted_probabilities_probit <- predict(fitted_probit, type = "response")

# Thêm dự báo vào dataset gốc
dd$predicted_probabilities_probit <- predicted_probabilities_probit

# Xem dataset với dự báo
head(dd)

probit(π(x))= 0.2871 + 0.0050inc + 0.0129nettfa + 0.1772pira + 0.0609marr

4.2.2 Phân tích p401k

library(readxl)
dt <- read_excel("C:/users/user/Downloads/ne.xlsx", sheet = "Sheet1")
fitted_probit <- glm(factor(p401k) ~ inc + nettfa + factor(pira) + factor(marr), family = binomial(link = 'probit'), data = dt)

## Warning: glm.fit: algorithm did not converge

summary(fitted_probit)

## 
## Call:
## glm(formula = factor(p401k) ~ inc + nettfa + factor(pira) + factor(marr), 
##     family = binomial(link = "probit"), data = dt)
## 
## Coefficients:
##                Estimate Std. Error z value Pr(>|z|)    
## (Intercept)   0.1898101  0.0510420   3.719 0.000200 ***
## inc           0.0040792  0.0011455   3.561 0.000369 ***
## nettfa        0.0032060  0.0006385   5.021 5.14e-07 ***
## factor(pira)1 0.2152550  0.0558949   3.851 0.000118 ***
## factor(marr)1 0.0315086  0.0509390   0.619 0.536210    
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 4415.8  on 3636  degrees of freedom
## Residual deviance: 4237.2  on 3632  degrees of freedom
## AIC: 4247.2
## 
## Number of Fisher Scoring iterations: 25

# Dự báo xác suất trên cùng dữ liệu
predicted_probabilities_probit <- predict(fitted_probit, type = "response")

# Thêm dự báo vào dataset gốc
dt$predicted_probabilities_probit <- predicted_probabilities_probit

# Xem dataset với dự báo
head(dt)

probit(π(x))= 0.1898 + 0.0040inc + 0.0032nettfa + 0.2152pira + 0.0315marr