library(tidyverse)
library(readxl)
library(DT)
library(DescTools)
library(epitools)
library(scales)
data <- read_excel("C:/Users/tranh/Downloads/PTDLDT/CPSSW9204.xlsx")
dt <- data
datatable(dt,options = list(scrollX = TRUE))

Về bộ dữ liệu “CPSSW9204”, dữ liệu chứa 15.588 quan sát trên 5 biến, cung cấp phân phối thu nhập dành cho người lao động toàn thời gian có trình độ đại học trong độ tuổi 25–34 ở Mỹ vào năm 1992 và 2004. Các biến có trong dữ liệu:

  1. year: biến chỉ năm thực hiện khảo sát

  2. earnings: Thu nhập trung bình hàng giờ

  3. degree: Trình độ học vấn bao gồm 2 biểu hiện đại học(bachelor) và trung học(highschool)

  4. gender: yếu tố chỉ giới tính bao gồm 2 biểu hiện male: nam và female: nữ.

  5. age: tuổi người tham gia khảo sát, tính bằng năm.

1.Thống kê mô tả các biến định tính

1.1. Thống kê mô tả biến degree

tmp <- table(dt$degree)
addmargins(tmp)
## 
##   bachelor highschool        Sum 
##       6602       8986      15588
round((table(dt$degree)/sum(table(dt$degree))*100),2)
## 
##   bachelor highschool 
##      42.35      57.65
dt %>% ggplot(map = aes(x=degree, y= after_stat(count)))+geom_bar(fill = 'violet')+geom_text(aes(label=percent(after_stat(count/sum(count)),accuracy = .01)), stat = 'count', color = 'black',vjust = 2) + labs(tiltle = 'Đồ thị thể hiện trình độ học vấn', x = 'Loại', y = 'số lượng')

Nhận xét: Trong tổng số 15588 người được khảo sát có:

  • 6602 người có trình độ học vấn là đại học, chiếm 42.35%.

  • 8986 người có trình độ học vấn là trung học, chiếm 57.65%.

Qua đó, có thể nhận thấy số người có trình độ học vấn là đại học thấp hơn số người có trình độ học vấn là trung học là 2384 người (chiếm 15.3%).

1.2. Thống kê mô tả biến gender

tmp1 <- table(dt$gender)
addmargins(tmp1)
## 
## female   male    Sum 
##   6553   9035  15588
round((table(dt$gender)/sum(table(dt$gender))*100),2)
## 
## female   male 
##  42.04  57.96
dt %>% ggplot(map = aes(x=gender, y= after_stat(count)))+geom_bar(fill = 'beige')+geom_text(aes(label=percent(after_stat(count/sum(count)),accuracy = .01)), stat = 'count', color = 'brown',vjust = 2) + labs(tiltle = 'Đồ thị thể hiện cho giới tính', x = 'Biểu hiện', y = 'số lượng')

Nhận xét: Trong tổng số 15588 người được khảo sát có:

  • 6553 người có giới tính là nữ, chiếm 42.04%.

  • 9035 người có giới tính là nam, chiếm 57.96%.

Qua đó, có thể nhận thấy số người có giới tính là nữ ít hơn số giới tính nam là 2482 người( chiếm 15.92%).

2.Thống kê mô tả cho biến định lượng

2.1. Thống kê mô tả biến earnings

summary(dt$earnings)
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##   1.500   8.974  12.500  14.263  17.576  61.058
var(dt$earnings)
## [1] 60.97475
sd(dt$earnings)
## [1] 7.808633
ggplot(dt, aes(x = earnings)) +
  geom_density(fill = "skyblue", color = "blue", alpha = 0.5) +
  labs(x = "Mức thu nhập trung bình theo giờ")

Từ kết quả các đặt trưng đo lường, ta biết:

  • Mức thu nhập trung bình hàng giờ cao nhất 61.058 USD. Mức thu nhập trung bình hàng giờ thấp nhất 1.500 USD. Mức thu nhập trung bình là 14.263 USD.

  • Số trung vị là 12.500 USD, cho biết có 50% trong 15588 người có thu nhập thấp hơn 12.500 USD.Tứ phân vị thứ nhất là 8.974, cho biết có 25% trong 15588 người có thu nhập thấp hơn 8.974 USD. Tứ phân vị tứ ba là 17.576 USD, cho biết có 75% trong số 15588 người có thu nhập bé hơn 17.576

  • Độ lệch chuẩn là 7.808633, có biết mức độ phân tán của từng mức thu nhập 15588 người được khảo sát xung quanh giá trị trung bình.

summary(dt$age)
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##   25.00   27.00   30.00   29.73   32.00   34.00
ggplot(dt, aes(x = age)) +
  geom_histogram(fill = "pink", color = "skyblue", bins = 10) +
  labs(x = "Tuổi")

Từ kết quả các đặt trưng đo lường theo độ tuổi người khảo sát, ta biết:

  • Độ tuổi cao nhất là 34, thấp nhất là 25 tuổi. Độ tuổi trung bình của số người tham gia khảo sát là 29.73 tuổi.

  • Có 50% trong 15588 người có tuổi nhỏ hơn 30. Có 25% trong 15588 người có tuổi nhỏ hơn 27. Có 25% trong số 15588 người lớn hơn 32 tuổi.

Dựa trên những đặc trưng đo lường, tiến hành phân tổ hai biến định lượng.

dt$earcoded <- cut(dt$earnings, breaks=c(1,15,62),labels=c('thap','cao'))
dt$agecoded <- cut(dt$age, breaks=c(24,29.5,35),labels=c('duoi 30','tren 30'))
table(dt$agecoded)
## 
## duoi 30 tren 30 
##    7242    8346
table(dt$earcoded)
## 
## thap  cao 
## 9987 5601
prop.table(table(dt$earcoded))
## 
##      thap       cao 
## 0.6406851 0.3593149

3. Phân tích

3.1. Phân tích sự ảnh hưởng của trình độ học vấn lên mức thu nhập theo giờ

3.1.1. Bảng tần số

table(dt$degree,dt$earcoded)
##             
##              thap  cao
##   bachelor   3024 3578
##   highschool 6963 2023
round((table(dt$degree,dt$earcoded)/sum(table(dt$degree,dt$earcoded))*100),2)
##             
##               thap   cao
##   bachelor   19.40 22.95
##   highschool 44.67 12.98
addmargins(table(dt$degree,dt$earcoded))
##             
##               thap   cao   Sum
##   bachelor    3024  3578  6602
##   highschool  6963  2023  8986
##   Sum         9987  5601 15588
dt %>% count(earcoded,degree) %>% group_by(degree) %>% mutate(psl = n/sum(n)) %>% ggplot(aes(x=degree,y=n,fill=earcoded))+geom_col() + geom_text(aes(label = percent(psl,accuracy = .01)), position = position_stack(vjust = .5), color = 'black') + labs( x ='Trình độ học vấn', y = 'số lượng')

Nhận xét:

  • Trong số những người với trình độ học vấn là đại học (bachelor), người có thu nhập thấp là 3024 người (chiếm 19.40% trên tổng số người tham gia khảo sát và chiếm 45.8% số người có trình độ học vấn là đại học), số người có thu nhập cao là 3578 (chiếm 22.95% trên tổng số người có tham gia khảo sát và chiếm 54.20% trên tổng số người có trình độ học vấn là đại học).

  • Trong số những người có trình độ học vấn là trung học (highschool), số người có thu nhập thấp là 6963 người (chiếm 44.67% trên tổng số người tham gia khảo sát và chiếm 77.49% số người có trình độ học vấn là trung học), số người có thu nhập cao là 2023 người (chiếm 12.98% trên tổng số người khảo sát và chiếm 22.51% trên tổng số người có trình độ là trung học).

3.1.2. Relative Risk

tmp2 <- table(dt$degree, dt$earcoded)
RelRisk(tmp2)
## [1] 0.5911209
riskratio(tmp2, rev = 'b')
## $data
##             
##               cao thap Total
##   highschool 2023 6963  8986
##   bachelor   3578 3024  6602
##   Total      5601 9987 15588
## 
## $measure
##             risk ratio with 95% C.I.
##               estimate     lower     upper
##   highschool 1.0000000        NA        NA
##   bachelor   0.5911209 0.5745076 0.6082146
## 
## $p.value
##             two-sided
##              midp.exact fisher.exact chi.square
##   highschool         NA           NA         NA
##   bachelor            0            0          0
## 
## $correction
## [1] FALSE
## 
## attr(,"method")
## [1] "Unconditional MLE & normal approximation (Wald) CI"
epitab(tmp2, method = 'riskratio', rev = 'c')
## $tab
##             
##               cao       p0 thap       p1 riskratio    lower    upper p.value
##   bachelor   3578 0.541957 3024 0.458043  1.000000       NA       NA      NA
##   highschool 2023 0.225128 6963 0.774872  1.691701 1.644157 1.740621       0
## 
## $measure
## [1] "wald"
## 
## $conf.level
## [1] 0.95
## 
## $pvalue
## [1] "fisher.exact"

Nhận xét:

Từ kết quả trên, ta có:

Tỷ số rủi ro là 0.5911209 với khoảng tin cậy 95% từ 0.5745076 đến 0.6082146. Điều này có nghĩa là những người có bằng đại học có tỷ lệ thu nhập thấp bằng 0.591 lần so với những người có bằng trung học. Khoảng tin cậy 95% cho biết rằng chúng ta có thể tin tưởng rằng giá trị thực của tỷ số rủi ro nằm trong khoảng từ 0.5745076 đến 0.6082146 với xác suất 95%.

3.1.3. Tỷ lệ chênh - Oddratio

OddsRatio(tmp2)
## [1] 0.2455506
oddsratio(tmp2)
## $data
##             
##              thap  cao Total
##   bachelor   3024 3578  6602
##   highschool 6963 2023  8986
##   Total      9987 5601 15588
## 
## $measure
##             odds ratio with 95% C.I.
##               estimate     lower     upper
##   bachelor   1.0000000        NA        NA
##   highschool 0.2455912 0.2291396 0.2631577
## 
## $p.value
##             two-sided
##              midp.exact fisher.exact chi.square
##   bachelor           NA           NA         NA
##   highschool          0            0          0
## 
## $correction
## [1] FALSE
## 
## attr(,"method")
## [1] "median-unbiased estimate & mid-p exact CI"
epitab(tmp2, method = 'oddsratio')
## $tab
##             
##              thap        p0  cao        p1 oddsratio     lower     upper
##   bachelor   3024 0.3027936 3578 0.6388145 1.0000000        NA        NA
##   highschool 6963 0.6972064 2023 0.3611855 0.2455506 0.2291233 0.2631556
##             
##              p.value
##   bachelor        NA
##   highschool       0
## 
## $measure
## [1] "wald"
## 
## $conf.level
## [1] 0.95
## 
## $pvalue
## [1] "fisher.exact"

Nhận xét:

  • Nhóm tham chiếu (bachelor) có tỷ số odds là 1.

  • Nhóm highschool có tỷ số odds là 0.2455912, nghĩa là nhóm này có khả năng có thu nhập cao thấp hơn khoảng 0.246 lần so với thu nhập nhóm có bằng cao đẳng/đại học. Khoảng tin cậy 95% cho tỷ số odds của nhóm highschool là từ 0.2291396 đến 0.2631577, cho thấy kết quả này rất đáng tin cậy.

  • Giá trị p - value = 0 cho nhóm highschool, điều này cho thấy sự khác biệt này là rất có ý nghĩa thống kê.

Tóm lại, kết quả này cho thấy sự khác biệt có ý nghĩa giữa hai nhóm trình độ học vấn về khả năng đạt được kết quả thu nhập “cao” hoặc “thap”, với nhóm trình độ trung học có tỷ lệ chênh để đạt kết quả thu nhập “cao” thấp hơn so với nhóm trình độ đại học.

3.2. Phân tích sự ảnh hưởng của giới tính lên mức thu nhập theo giờ

3.2.1. Bảng tần số

table(dt$gender,dt$earcoded)
##         
##          thap  cao
##   female 4636 1917
##   male   5351 3684
round((table(dt$gender,dt$earcoded)/sum(table(dt$gender,dt$earcoded))*100),2)
##         
##           thap   cao
##   female 29.74 12.30
##   male   34.33 23.63
addmargins(table(dt$gender,dt$earcoded))
##         
##           thap   cao   Sum
##   female  4636  1917  6553
##   male    5351  3684  9035
##   Sum     9987  5601 15588
dt %>% count(earcoded,gender) %>% group_by(gender) %>% mutate(psl = n/sum(n)) %>% ggplot(aes(x=gender,y=n,fill=earcoded))+geom_col() + geom_text(aes(label = percent(psl,accuracy = .01)), position = position_stack(vjust = .5), color = 'black') + labs( x ='Giới tính', y = 'số lượng')

Nhận xét:

  • Trong số những người có giới tính là nữ, số người có thu nhập thấp là 4636 (chiếm 70.75% trên tổng số nữ, và chiếm 29.74), số người có thu nhập cao là 1917 ( chiếm 29.25% trên tổng số nữ và chiếm 12.3% trên tổng số người được khảo sát)

  • Trong số những người có giới tính là nam, số người có thu nhập thấp là 5351 (chiếm 59.23% trên tổng số nam và chiếm 34.33% trên tổng số quan sát), số người có thu nhập cao là 3684 (chiếm 40.77% trên tổng số nam và chiếm 23.63% trên tổng quan sát).

3.2.2. Relative Risk

cpm <- table(dt$gender, dt$earcoded)
RelRisk(cpm)
## [1] 1.194528
riskratio(cpm, rev = 'b')
## $data
##         
##           cao thap Total
##   male   3684 5351  9035
##   female 1917 4636  6553
##   Total  5601 9987 15588
## 
## $measure
##         risk ratio with 95% C.I.
##          estimate    lower    upper
##   male   1.000000       NA       NA
##   female 1.194528 1.167213 1.222483
## 
## $p.value
##         two-sided
##          midp.exact fisher.exact   chi.square
##   male           NA           NA           NA
##   female          0 5.071489e-50 1.497043e-49
## 
## $correction
## [1] FALSE
## 
## attr(,"method")
## [1] "Unconditional MLE & normal approximation (Wald) CI"
epitab(cpm, method = 'riskratio', rev = 'c')
## $tab
##         
##           cao        p0 thap        p1 riskratio     lower     upper
##   female 1917 0.2925378 4636 0.7074622 1.0000000        NA        NA
##   male   3684 0.4077476 5351 0.5922524 0.8371505 0.8180072 0.8567418
##         
##               p.value
##   female           NA
##   male   5.071489e-50
## 
## $measure
## [1] "wald"
## 
## $conf.level
## [1] 0.95
## 
## $pvalue
## [1] "fisher.exact"

Nhận xét:

Từ kết quả trên, ta có:

Tỷ số rủi ro là 1.194528. Điều này có nghĩa là những người giới tính nữ có nguy cơ đạt thu nhập cao cao hơn 1.19 lần so với thu nhập những người nam. Khoảng tin cậy 95% cho biết rằng chúng ta có thể tin tưởng rằng giá trị thực của tỷ số rủi ro nằm trong khoảng từ (1.167213, 1.222483) với xác suất 95%.

3.2.3. Tỷ lệ chênh - Oddratio

OddsRatio(cpm)
## [1] 1.664968
oddsratio(cpm)
## $data
##         
##          thap  cao Total
##   female 4636 1917  6553
##   male   5351 3684  9035
##   Total  9987 5601 15588
## 
## $measure
##         odds ratio with 95% C.I.
##          estimate    lower    upper
##   female 1.000000       NA       NA
##   male   1.664883 1.555942 1.781767
## 
## $p.value
##         two-sided
##          midp.exact fisher.exact   chi.square
##   female         NA           NA           NA
##   male            0 5.071489e-50 1.497043e-49
## 
## $correction
## [1] FALSE
## 
## attr(,"method")
## [1] "median-unbiased estimate & mid-p exact CI"
epitab(cpm, method = 'oddsratio')
## $tab
##         
##          thap        p0  cao        p1 oddsratio    lower    upper      p.value
##   female 4636 0.4642035 1917 0.3422603  1.000000       NA       NA           NA
##   male   5351 0.5357965 3684 0.6577397  1.664968 1.555868 1.781719 5.071489e-50
## 
## $measure
## [1] "wald"
## 
## $conf.level
## [1] 0.95
## 
## $pvalue
## [1] "fisher.exact"

Tỉ lệ (Odds Ratio) (Nam so với Nữ):

  • Ước lượng: 1.664883

  • Khoảng tin cậy 95%: (1.555942, 1.781767)

  • Giá trị p: < 2.2e-16

  • Giá trị p rất nhỏ, chỉ ra sự khác biệt đáng kể về tỷ lệ tỷ lệ cơ hội giữa nam và nữ.

  • Kết quả phân tích odds ratio này cho thấy rằng tỷ lệ là khoảng 1.66 lần cao hơn ở nam so với nữ, với một mức ý nghĩa đáng kể.

Thống kê suy diễn cho dữ liệu định tính

Kiểm định tính độc lập cho 2 biến định tính:

Giả thuyết \(H_0\): X,Y độc lập.

Giả thuyết \(H_1\): X,Y không độc lập.

Kiểm định tính độc lập giữa hai biến trình độ học vấn (degree) và thu nhập theo giờ (earcoded)

tmp2 <- table(dt$degree, dt$earcoded)
chisq.test(tmp2)
## 
##  Pearson's Chi-squared test with Yates' continuity correction
## 
## data:  tmp2
## X-squared = 1658.1, df = 1, p-value < 2.2e-16

Qua kết quả kiểm định cho ta p−value < 2.2e−16 < 0.05, nên bác bỏ H0, nghĩa là trình độ học vấn và mức thu nhập là có liên quan với nhau.

Kiểm định tính độc lập giữa hai biến tuổi và thu nhập theo giờ.

tmp3 <- table(dt$agecoded, dt$earcoded)
chisq.test(tmp3)
## 
##  Pearson's Chi-squared test with Yates' continuity correction
## 
## data:  tmp3
## X-squared = 181.64, df = 1, p-value < 2.2e-16

Qua kết quả kiểm định cho ta p−value < 2.2e−16 < 0.05, nên bác bỏ H0, nghĩa là tuổi người tham gia khảo sát và mức thu nhập là có liên quan với nhau.

Kiểm định tính độc lập giữa hai biến giới tính và thu nhập theo giờ.

tmp4 <- table(dt$gender, dt$earcoded)
chisq.test(tmp4)
## 
##  Pearson's Chi-squared test with Yates' continuity correction
## 
## data:  tmp4
## X-squared = 218.5, df = 1, p-value < 2.2e-16

Qua kết quả kiểm định cho ta p−value < 2.2e−16 < 0.05, nên bác bỏ H0, nghĩa là giới tính người tham gia khảo sát và mức thu nhập là có liên quan với nhau.

Khoảng ước lượng cho tỷ lệ

Ước lượng tỷ lệ người có thu nhập cao đồng thời kiểm định xem tỷ lệ % người có thu nhập cao có phải là 36% không. \(H_0=0.36\)

tmp5 <- dt[dt$earcoded=="cao",]
tmp5
## # A tibble: 5,601 × 8
##    rownames  year earnings degree     gender   age earcoded agecoded
##       <dbl> <dbl>    <dbl> <chr>      <chr>  <dbl> <fct>    <fct>   
##  1        8  1992     17.8 highschool male      33 cao      tren 30 
##  2       15  1992     23.6 bachelor   male      29 cao      duoi 30 
##  3       23  1992     19.2 highschool male      34 cao      tren 30 
##  4       28  1992     15.7 highschool male      30 cao      tren 30 
##  5       37  1992     17.4 bachelor   male      33 cao      tren 30 
##  6       56  1992     15.4 bachelor   male      31 cao      tren 30 
##  7       58  1992     17.1 bachelor   female    33 cao      tren 30 
##  8       62  1992     17.6 highschool male      29 cao      duoi 30 
##  9       78  1992     22.4 bachelor   male      33 cao      tren 30 
## 10       79  1992     16.0 highschool male      30 cao      tren 30 
## # ℹ 5,591 more rows
prop.test(length(tmp5$earcoded), length(dt$earcoded), p = 0.36)
## 
##  1-sample proportions test with continuity correction
## 
## data:  length(tmp5$earcoded) out of length(dt$earcoded), null probability 0.36
## X-squared = 0.028855, df = 1, p-value = 0.8651
## alternative hypothesis: true p is not equal to 0.36
## 95 percent confidence interval:
##  0.3517864 0.3669129
## sample estimates:
##         p 
## 0.3593149

Không có bằng chứng thống kê để bác bỏ giả thuyết rằng tỷ lệ thu nhập cao trong mẫu dữ liệu là 36%. Nói cách khác, tỷ lệ thu nhập cao trong dữ liệu không khác biệt đáng kể so với tỷ lệ giả thuyết 36%.

Ước lượng sự chênh lệch về tỷ lệ thu nhập cao giữa người có trình độ học vấn là đại học và trung học.

Thực hiện bài toán kiểm định giả thuyết sự bằng nhau về tỷ lệ thu nhập cao của tổng thể (bachelor và highschool), nghĩa là chúng ta thực hiện bài toán kiểm định H0:p1=p2.

tmpm <- dt[dt$degree == 'bachelor',]
tmpm
## # A tibble: 6,602 × 8
##    rownames  year earnings degree   gender   age earcoded agecoded
##       <dbl> <dbl>    <dbl> <chr>    <chr>  <dbl> <fct>    <fct>   
##  1        1  1992    11.2  bachelor male      29 thap     duoi 30 
##  2        2  1992    10    bachelor male      33 thap     tren 30 
##  3        5  1992    15.0  bachelor male      31 thap     tren 30 
##  4        6  1992     8.66 bachelor female    26 thap     duoi 30 
##  5       11  1992    14.4  bachelor male      30 thap     tren 30 
##  6       12  1992     7.93 bachelor female    30 thap     tren 30 
##  7       13  1992    13.7  bachelor female    34 thap     tren 30 
##  8       15  1992    23.6  bachelor male      29 cao      duoi 30 
##  9       16  1992     9.16 bachelor male      31 thap     tren 30 
## 10       25  1992     6.01 bachelor male      31 thap     tren 30 
## # ℹ 6,592 more rows
tmpf <- dt[dt$degree == 'highschool',]
tmpf
## # A tibble: 8,986 × 8
##    rownames  year earnings degree     gender   age earcoded agecoded
##       <dbl> <dbl>    <dbl> <chr>      <chr>  <dbl> <fct>    <fct>   
##  1        3  1992     5.77 highschool male      30 thap     tren 30 
##  2        4  1992     1.56 highschool male      32 thap     tren 30 
##  3        7  1992     7.79 highschool female    31 thap     tren 30 
##  4        8  1992    17.8  highschool male      33 cao      tren 30 
##  5        9  1992    11.1  highschool male      29 thap     duoi 30 
##  6       10  1992    12.1  highschool male      30 thap     tren 30 
##  7       14  1992     7.21 highschool female    26 thap     duoi 30 
##  8       17  1992    11.7  highschool female    34 thap     tren 30 
##  9       18  1992     6.73 highschool male      32 thap     tren 30 
## 10       19  1992    12.5  highschool male      30 thap     tren 30 
## # ℹ 8,976 more rows
tmpm3 <- tmpm[tmpm$earcoded=="cao",]
tmpf3 <- tmpf[tmpf$earcoded=="cao",]

a <- c(nrow(tmpm), nrow(tmpf))
b <- c(nrow(tmpm3), nrow(tmpf3))

prop.test(b,a)
## 
##  2-sample test for equality of proportions with continuity correction
## 
## data:  b out of a
## X-squared = 1658.1, df = 1, p-value < 2.2e-16
## alternative hypothesis: two.sided
## 95 percent confidence interval:
##  0.3018984 0.3317596
## sample estimates:
##   prop 1   prop 2 
## 0.541957 0.225128

Có sự khác biệt có ý nghĩa thống kê giữa tỷ lệ thu nhập cao của nhóm người tốt nghiệp đại học và trung học. Tỷ lệ người tốt nghiệp đại học có thu nhập cao (54.20%) cao hơn đáng kể so với tỷ lệ người tốt nghiệp trung học có thu nhập cao (22.51%). Điều này được củng cố bởi giá trị p rất nhỏ và khoảng tin cậy không bao gồm 0.