Nhiệm vụ 2

Dữ liệu Khoảng cách Đại học

Giới thiệu bộ dữ liệu CollegeDistance

Dữ liệu từ cuộc khảo sát High School and Beyond được tiến hành bởi Bộ Giáo dục vào năm 1980, với một cuộc theo dõi vào năm 1986. Cuộc khảo sát bao gồm học sinh từ khoảng 1.100 trường trung học.

library(readxl)

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

CollegeDistance <- read_excel("C:/Users/admin/Downloads/CollegeDistance.xlsx")
View(CollegeDistance)

Định dạng

Một khung dữ liệu chứa 4.739 quan sát trên 14 biến.

gender: giới tính.

ethnicity: dân tộc (Người Mỹ gốc Phi, người Mỹ gốc Latin hoặc khác).

score: điểm kiểm tra tổng hợp năm cơ sở

fcollege: Cha có tốt nghiệp đại học không?

mcollege: Mẹ có tốt nghiệp đại học không?

home: Gia đình Có sở hữu nhà riêng không?

urban: Trường có nằm trong khu vực đô thị không?

unemp: tỷ lệ thất nghiệp vào năm 1980.

wage: mức lương hàng giờ của tiểu bang trong ngành sản xuất vào năm 1980.

distance: khoảng cách từ trường đại học 4 năm (tính bằng 10 dặm).

tuition: học phí trung bình của trường đại học 4 năm của tiểu bang (tính bằng 1000 USD).

education: số năm học.

income: Thu nhập gia đình có vượt quá 25.000 USD mỗi năm không?

region: Vùng (Tây hoặc khác).

Mô tả dữ liệu

tính số năm học bằng cách gán 12 năm cho tất cả các thành viên của lớp học cuối cùng. Mỗi năm học trung học bổ sung được tính là một năm. Học sinh có bằng cấp nghề được gán 13 năm, bằng cấp AA được gán 14 năm, bằng cấp BA được gán 16 năm, những người có một số giáo dục sau đại học được gán 17 năm và những người có bằng cấp sau đại học được gán 18 năm.

t <- CollegeDistance
str(t)

## tibble [4,739 × 15] (S3: tbl_df/tbl/data.frame)
##  $ rownames : num [1:4739] 1 2 3 4 5 6 7 8 9 10 ...
##  $ gender   : chr [1:4739] "male" "female" "male" "male" ...
##  $ ethnicity: chr [1:4739] "other" "other" "other" "afam" ...
##  $ score    : num [1:4739] 39.2 48.9 48.7 40.4 40.5 ...
##  $ fcollege : chr [1:4739] "yes" "no" "no" "no" ...
##  $ mcollege : chr [1:4739] "no" "no" "no" "no" ...
##  $ home     : chr [1:4739] "yes" "yes" "yes" "yes" ...
##  $ urban    : chr [1:4739] "yes" "yes" "yes" "yes" ...
##  $ unemp    : num [1:4739] 6.2 6.2 6.2 6.2 5.6 ...
##  $ wage     : num [1:4739] 8.09 8.09 8.09 8.09 8.09 ...
##  $ distance : num [1:4739] 0.2 0.2 0.2 0.2 0.4 ...
##  $ tuition  : num [1:4739] 0.889 0.889 0.889 0.889 0.889 ...
##  $ education: num [1:4739] 12 12 12 12 13 12 13 15 13 15 ...
##  $ income   : chr [1:4739] "high" "low" "low" "low" ...
##  $ region   : chr [1:4739] "other" "other" "other" "other" ...

Phân tích

Phân tích gia đình có sở hữu nhà qua việc thu nhập có cao hay thấp (25.000 USD mỗi năm)

income: Thu nhập gia đình có vượt quá 25.000 USD mỗi năm không?

home: Gia đình Có sở hữu nhà riêng không?

library(DT)

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

library(tidyverse)

## Warning: package 'tidyverse' was built under R version 4.3.3

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

## Warning: package 'tibble' was built under R version 4.3.3

## Warning: package 'tidyr' was built under R version 4.3.3

## Warning: package 'readr' was built under R version 4.3.3

## Warning: package 'purrr' was built under R version 4.3.3

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

## Warning: package 'stringr' was built under R version 4.3.3

## Warning: package 'forcats' was built under R version 4.3.3

## Warning: package 'lubridate' was built under R version 4.3.3

## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ dplyr     1.1.4     ✔ readr     2.1.5
## ✔ forcats   1.0.0     ✔ stringr   1.5.1
## ✔ ggplot2   3.5.1     ✔ tibble    3.2.1
## ✔ lubridate 1.9.3     ✔ tidyr     1.3.1
## ✔ purrr     1.0.2     
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## ✖ dplyr::filter() masks stats::filter()
## ✖ dplyr::lag()    masks stats::lag()
## ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors

t$home <- recode(t$home,"yes"="có sở hữu nhà","no"="không sở hữu nhà")
t$income <- recode(t$income,"high"="Cao","low"="Thấp")
t$ethnicity <- recode(t$ethnicity,"afam"="Người Mỹ gốc Phi","hispanic"="Người Mỹ gốc Latin","other"="Người Mỹ gốc khác")

Lập bảng tần số và vẽ đồ thị cột

Bảng tần số biến Home

table(t$home)

## 
##    có sở hữu nhà không sở hữu nhà 
##             3887              852

prop.table(table(t$home))

## 
##    có sở hữu nhà không sở hữu nhà 
##        0.8202152        0.1797848

Nhận xét: Ta thấy được việc gia đình Có sở hữu nhà chiếm tỷ lệ rất cao khoảng 82.02% so với các gia đình Không sở hữu nhà là 17.98%

library(ggplot2)
t |> ggplot(aes(x = t$home, y = after_stat(count))) +
geom_bar(fill = 'green') +geom_text(aes(label = scales::percent(after_stat(count/sum(count)))), stat ='count', color = 'red', vjust = - .5) +labs(x = 'Sở hữu nhà', y = 'Số gia đình')

## Warning: Use of `t$home` is discouraged.
## ℹ Use `home` instead.
## Use of `t$home` is discouraged.
## ℹ Use `home` instead.

Bảng tần số biến Income

table(t$income)

## 
##  Cao Thấp 
## 1365 3374

prop.table(table(t$income))

## 
##       Cao      Thấp 
## 0.2880355 0.7119645

Nhận xét: Theo như kết quả trên thì việc các gia đình thu nhập cao (trên 25.000 USD/năm) chiếm tỷ lệ thấp khoảng 28.8% và còn lại là 71.2% các gia đình có thu nhập thấp

t |> ggplot(aes(x = t$income, y = after_stat(count))) +
geom_bar(fill = 'cyan') +geom_text(aes(label = scales::percent(after_stat(count/sum(count)))), stat ='count', color = 'red', vjust = - .5) +labs(x = 'Mức thu nhập', y = 'Số gia đình')

## Warning: Use of `t$income` is discouraged.
## ℹ Use `income` instead.
## Use of `t$income` is discouraged.
## ℹ Use `income` instead.

ggplot(t, aes(home, fill = income)) + geom_bar(position = 'dodge')  

Nhận xét: Độ thị hiển thị kết quả của 2 bảng tần số trên, ta có thể thấy được việc sở hữu nhà và mức thu nhập có liên quan đến nhau, cụ thể như việc gia đình có nhà mà thu nhập cao chiếm 1/3 nhóm sở hữu nhà và ngược lại thì nhóm không có nhà mà gia đình có mức thu nhập cao lại chiếm tỷ lệ rất thấp.

Ước lượng tỷ lệ

Biến Home và Biến Income

addmargins(table(t$income,t$home))

##       
##        có sở hữu nhà không sở hữu nhà  Sum
##   Cao           1234              131 1365
##   Thấp          2653              721 3374
##   Sum           3887              852 4739

prop.table(addmargins(table(t$income,t$home)))

##       
##        có sở hữu nhà không sở hữu nhà         Sum
##   Cao    0.065098122      0.006910741 0.072008863
##   Thấp   0.139955687      0.038035451 0.177991137
##   Sum    0.205053809      0.044946191 0.250000000

Nhận xét: Xét việc sở hữu nhà phụ thuộc vào mức độ thu nhập của mỗi hộ gia đình

Tỷ lệ gia đình có thu nhập cao nhưng lại Không sở hữu nhà chiếm 0.69% trong nhóm có mức thu nhập cao nhưng lại thấp hơn tỷ lệ gia đình có thu nhập thấp mà không có nhà ở chiếm 3.8% trong nhóm có mức thu thập thấp.

Tỷ lệ gia đình có thu nhập cao và sở hữu nhà chiếm 6.51% trong nhóm có mức thu nhập cao nhưng lại thấp hơn tỷ lệ gia đình có thu nhập thấp và sở hữu nhà chiếm 13.99% trong nhóm có mức thu nhập thấp.

Ước lượng tỷ lệ gia đình sở hữu nhà (biến Home)

ta kiểm định giả thuyết: H(0): Ước lượng tỷ lệ gia đình Có nhà ở (p) trong nhóm sở hữu nhà là 0.4 (40%).

rhy <- t[t$home == 'có sở hữu nhà',]

prop.test(length(rhy$home), length(t$home), p = 0.4)

## 
##  1-sample proportions test with continuity correction
## 
## data:  length(rhy$home) out of length(t$home), null probability 0.4
## X-squared = 3485, df = 1, p-value < 2.2e-16
## alternative hypothesis: true p is not equal to 0.4
## 95 percent confidence interval:
##  0.8089162 0.8309906
## sample estimates:
##         p 
## 0.8202152

Kết quả trên cho ta thấy giá trị kiểm định p-value < 2.2e-16 gần như là bằng 0 và nhỏ hơn giá trị α = 0.05 cho thấy giả thuyết H(0) có thể bác bỏ rằng tỷ lệ gia đình có nhà ở trong nhóm sở hữu nhà với xác suất 82.02%. Với độ tin cậy 95% thì khoảng xác suất là 80.9% đến 83.1%.

ta kiểm định giả thuyết: H(0): Ước lượng tỷ lệ gia đình không Có sở hữu nhà ở (p) trong nhóm sở hữu nhà là 0.6 (60%).

rhn <- t[t$home == 'không sở hữu nhà',]

prop.test(length(rhn$home), length(t$home), p = 0.6)

## 
##  1-sample proportions test with continuity correction
## 
## data:  length(rhn$home) out of length(t$home), null probability 0.6
## X-squared = 3485, df = 1, p-value < 2.2e-16
## alternative hypothesis: true p is not equal to 0.6
## 95 percent confidence interval:
##  0.1690094 0.1910838
## sample estimates:
##         p 
## 0.1797848

Kết quả trên cho ta thấy giá trị kiểm định p-value < 2.2e-16 gần như là bằng 0 và nhỏ hơn giá trị α = 0.05 cho thấy giả thuyết H(0) có thể bác bỏ rằng tỷ lệ gia đình không có nhà ở trong nhóm sở hữu nhà với xác suất 17.97%. Với độ tin cậy 95% thì khoảng xác suất là 16.9% đến 19.1%.

Ước lượng tỷ lệ biến Income

ta kiểm định giả thuyết: H(0): Ước lượng tỷ lệ gia đình có thu nhập cao (p) trong nhóm thu nhập là 0.5 (50%).

rih <- t[t$income == 'Cao',]

prop.test(length(rih$income), length(t$income), p = 0.5)

## 
##  1-sample proportions test with continuity correction
## 
## data:  length(rih$income) out of length(t$income), null probability 0.5
## X-squared = 850.83, df = 1, p-value < 2.2e-16
## alternative hypothesis: true p is not equal to 0.5
## 95 percent confidence interval:
##  0.2752141 0.3012030
## sample estimates:
##         p 
## 0.2880355

Kết quả trên cho ta thấy giá trị kiểm định p-value < 2.2e-16 gần như là bằng 0 và nhỏ hơn giá trị α = 0.05 cho thấy giả thuyết H(0) có thể bác bỏ rằng tỷ lệ gia đình có thu nhập cao ở trong nhóm thu nhập với xác suất 28.8%. Với độ tin cậy 95% thì khoảng xác suất là 27.5% đến 30.12%.

ta kiểm định giả thuyết: H(0): Ước lượng tỷ lệ gia đình có thu nhập thấp (p) trong nhóm thu nhập là 0.8 (80%).

ril <- t[t$income == 'Thấp',]

prop.test(length(ril$home), length(t$income), p = 0.8)

## 
##  1-sample proportions test with continuity correction
## 
## data:  length(ril$home) out of length(t$income), null probability 0.8
## X-squared = 229, df = 1, p-value < 2.2e-16
## alternative hypothesis: true p is not equal to 0.8
## 95 percent confidence interval:
##  0.6987970 0.7247859
## sample estimates:
##         p 
## 0.7119645

Kết quả trên cho ta thấy giá trị kiểm định p-value < 2.2e-16 gần như là bằng 0 và nhỏ hơn giá trị α = 0.05 cho thấy giả thuyết H(0) có thể bác bỏ rằng tỷ lệ gia đình có thu nhập thấp ở trong nhóm thu nhập với xác suất 71.19%. Với độ tin cậy 95% thì khoảng xác suất là 69.87% đến 72.47%.

Ước lượng chênh lệch 2 tỷ lệ

Thực hiện bài toán kiểm định giả thuyết sự bằng nhau về tỷ lệ việc sở hữu nhà phụ thuộc vào mức thu nhập của 2 tổng thể

ty <- t[t$home == 'có sở hữu nhà',]
tn <- t[t$home == 'không sở hữu nhà',]

th <- ty[ty$income == 'Cao',]
tl <- tn[tn$income == 'Thấp' ,]

a <- c(nrow(ty), nrow(tn))
b <- c(nrow(th), nrow(tl))

prop.test(b,a)

## 
##  2-sample test for equality of proportions with continuity correction
## 
## data:  b out of a
## X-squared = 804.07, df = 1, p-value < 2.2e-16
## alternative hypothesis: two.sided
## 95 percent confidence interval:
##  -0.5577895 -0.4997617
## sample estimates:
##    prop 1    prop 2 
## 0.3174685 0.8462441

Ta có thể thấy rằng Tỷ lệ 1 “thành công” được hiểu là khi Mức thu nhập cao thì việc có nhà ở chiếm tỷ lệ 31.74% so với tổng thể 1 (Tổng số hộ gia đình có sở hữu nhà). Tỷ lệ 2 “thành công” được hiểu là khi mức thu nhập thấp thì việc không có nhà ở chiếm tỷ lệ 84.62% so với tổng thể 2 (Tổng số hộ gia đình không sở hữu nhà).

Ước lượng tỷ lệ Relative Risk

library(DescTools)

## Warning: package 'DescTools' was built under R version 4.3.3

x <- matrix(c(1234,131,2653,721),nrow = 2) 
RelRisk(x, conf.level = .95)

## rel. risk    lwr.ci    upr.ci 
##  2.064757  1.756302  2.437252

Kết quả cho thấy Tỷ lệ nhóm thu nhập cao và có sở hữu nhà gấp nhóm thu nhập cao mà không có sở hữu nhà khoảng 2.064757 lần. Với mức độ tin cậy 95%. Có 5% khả năng tỷ lệ rủi ro thực sự nằm ngoài khoảng 1.756302 và 2.437252.

Ước lượng Odd Ratio

library(epitools)
OddsRatio(x)

## [1] 2.560011

Nhận xét: Với kết quả này ta có hiểu là ta phải tính tỷ lệ 2 nhóm

Nhóm 1: Tỷ lệ giữa nhóm thu nhập cao mà có nhà và nhóm thu nhập cao mà không có nhà là 9.41, nghĩa là nhóm thu nhập cao mà có nhà sẽ 9.41 lần so với nhóm thu nhập cao mà không có nhà.

Nhóm 2: Tỷ lệ giữa nhóm thu nhập thấp mà có nhà và nhóm thu nhập thấp mà không có nhà là 3.68, nghĩa là nhóm thu nhập thấp mà có nhà sẽ gấp 3.68 lần so với nhóm thu nhập thấp mà không có nhà.

Vậy chỉ số OddsRatio là 2.56 có thể hiểu là tỷ lệ giữa nhóm 1 và nhóm 2 là 2.56 lần.

Ước lượng mô hình

library(GLMsData)
fitted <- glm(factor(t$home) ~ t$income, family = binomial(link = 'logit'), data = t )
summary(fitted)

## 
## Call:
## glm(formula = factor(t$home) ~ t$income, family = binomial(link = "logit"), 
##     data = t)
## 
## Coefficients:
##              Estimate Std. Error z value Pr(>|z|)    
## (Intercept)  -2.24282    0.09188 -24.410   <2e-16 ***
## t$incomeThấp  0.94001    0.10102   9.305   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 4464.8  on 4738  degrees of freedom
## Residual deviance: 4364.0  on 4737  degrees of freedom
## AIC: 4368
## 
## Number of Fisher Scoring iterations: 4

ta có hàm hồi quy là:

Gia đình sở hữu nhà (Home) = -2.24282 + 0.94001*Nhóm thu nhập thấp

Nhận xét: Nếu nhóm gia đình sở hữu nhà tăng 1 đơn vị thì nhóm thu nhập thấp sẽ tăng trung bình 0.94 đơn vị.