1. Sơ lược về bộ dữ liệu TeachingRatings:

2. Xử lý dữ liệu

Dựa trên điểm đánh giá ngoại hình, phân loại ngoại hình thành 4 mức: bình thường, ưa nhìn, đẹp và rất đẹp (từ -2 đến -1, từ -1 đến 0, từ 0 đến 1 và từ 1 trở lên)

Dựa vào sự phân loại này, em tiến hành đánh giá trực quan dựa trên đồ thị đánh giá ngoại hình của Giảng viên dựa trên 02 giới tính nam và nữ

install.packages("AER") # cài đặt package chứa dữ liệu TeachingRatings
library("AER")
library(ggplot2) # gọi thư viện vẽ đồ thị
data("TeachingRatings") # gọi Data TeachingRatings 
TeachingRatings$beauty_rank <- cut(TeachingRatings$beauty,
                                       breaks = c(-Inf, -1, 0, 1, Inf),
                                       labels = c("bình thường", "ưa nhìn", "đẹp", "rất đẹp")) # Dựa trên điểm đánh giá ngoại hình, phân loại ngoại hình thành 4 mức: bình thường, ưa nhìn, đẹp, rất đẹp
library(dplyr)
TeachingRatings <- TeachingRatings %>%
  mutate(gender = recode(gender, male = "Nam", female = "Nữ")) # Việt hoá biến Gender

2.1 Vẽ đồ thị

ggplot(TeachingRatings, aes(x = gender, fill = beauty_rank)) +
  geom_bar(position = "dodge") +
  labs(title = "Phân loại ngoại hình theo giới tính",
       x = "Giới tính",
       y = "Số lượng",
       fill = "Phân loại ngoại hình") +
  theme_minimal()

Biểu đồ thể hiện sự phân bố của chỉ số ưu nhìn của giảng viên do sinh viên trường Đại học Texas - Austin đánh giá từ năm 2000 đến năm 2002. Hơn nữa biểu đồ còn thể hiện sự phân bố mức độ ngoại hình của giảng viên tại đây với 4 mức độ: bình thường, ưa nhìn, đẹp, rất đẹp ở 02 giới tính Nam và Nữ. Trong đó, các cột được tô màu khác nhau dựa trên mức độ ngoại hình.

Ở mức độ “bình thường”, số lượng Giảng viên Nam được đánh giá bình thường nhiều hơn Giảng viên Nữ. Trong khi đó, ở mức độ ưa nhìn, số lượng Giảng viên Nam được đánh giá xấp xỉ gấp đôi số lượng Giảng viên Nữ. Tiếp tục ở mức độ “đẹp”, chúng ta thấy rằng số lượng Giảng viên Nam được đánh giá “đẹp” cao hơn số lượng Giảng viên Nữ. Cuối cùng ở mức độ “rất đẹp”, số lượng Giảng viên Nữ được đánh giá rất đẹp cao hơn Giảng viên Nam. Nhìn chung trừ mức độ “bình thường” giữa Giảng viên Nam và Giảng viên Nữ không có chênh lệch quá lớn.

3. Ước lượng tỉ lệ

Công thức ước lượng tỷ lệ (cho một tổng thể):
\(\hat{p} - Z_{\alpha/2}\sqrt{\frac{\hat{p}(1-\hat{p})}{n}} \le P \le \hat{p} - Z_{\alpha/2}\sqrt{\frac{\hat{p}(1-\hat{p})}{n}}\)

Trong đó:

• \(\hat{p}\) là tỷ lệ mẫu của mức độ ngoại hình

• \(P\) là tỷ lệ số lượng của từng phân loại ngoại hình

• \(Z_{\alpha/2}\) là giá trị critial từ phân phối chuẩn tương ứng với mức tin cậy \(1 - \alpha\).

• \(n\) là kích thước mẫu.

Giả sử chúng ta Ước lượng tỷ lệ Giảng viên có chỉ số mức độ ngoại hình lớn hơn 1 đồng thời kiểm định xem tỷ lệ (%) người có chỉ số mức độ ngoại hình lớn hơn 1 có phải là 36% hay không (Nghĩa là chúng ta kiểm định giả thuyết \(H_0\) = 0.36)

d <- TeachingRatings
rank <- d[d$beauty > 1,]
tr <- table(d$gender, d$beauty)
prop.test(length(rank$beauty), length(TeachingRatings$beauty), p = 0.36)

## 
##  1-sample proportions test with continuity correction
## 
## data:  length(rank$beauty) out of length(TeachingRatings$beauty), null probability 0.36
## X-squared = 92.211, df = 1, p-value < 2.2e-16
## alternative hypothesis: true p is not equal to 0.36
## 95 percent confidence interval:
##  0.1146123 0.1808470
## sample estimates:
##         p 
## 0.1447084

Kết quả cho thấy:

• Giá trị thống kê \(X^2\) là 116.35 với mức tự do là 1.

• Giá trị p (p-value) được hiển thị là \(< 2.2e^{-16}\), cho thấy có đủ bằng chứng để bác bỏ giả thuyết \(H_0\) = 0.36

• Chấp nhận giả thuyết \(H_1\)

• Khoảng tin cậy 95% cho tỷ lệ mức độ ngoại hình nằm trong khoảng từ 0.9324374 đến 1.0000000 tức là ở mức “đẹp”

4. Ước lượng hai tỷ lệ

Tiếp theo, tôi ước lượng sự chênh lệch về tỷ lệ chỉ số ngoại hình lớn hơn 1 của 2 giới tính Nam và Nữ \[ (\hat{p}_1 - \hat{p}_2) - Z_{\alpha/2} \sqrt{\frac{\hat{p}_1 (1 - \hat{p}_1)}{n_1} + \frac{\hat{p}_2 (1 - \hat{p}_2)}{n_2}} \leq p_1 - p_2 \leq (\hat{p}_1 - \hat{p}_2) + Z_{\alpha/2} \sqrt{\frac{\hat{p}_1 (1 - \hat{p}_1)}{n_1} + \frac{\hat{p}_2 (1 - \hat{p}_2)}{n_2}} \]

Trong đó:

• \(\hat{p}_1\) và \(\hat{p}_2\) là tỷ lệ chỉ số xếp hạng ngoại hình cao hơn 1 trong mẫu nam và nữ tương ứng.
• \(p_1\) và \(p_2\) là tỷ lệ chỉ số xếp hạng ngoại hình cao hơn 1 trong toàn bộ tổng thể nam và nữ tương ứng.
• \(n_1\) và \(n_2\) là kích thước của mẫu nam và nữ tương ứng.
• \(Z_{\alpha/2}\) là giá trị critial từ phân phối chuẩn tương ứng với mức tin cậy \(1 - \alpha\).

trmale <- d[d$gender == "Nam",]
trfemale <- d[d$gender == "Nữ",]

trm3 <- trmale[trmale$beauty > 1,]
trf3 <- trfemale[trfemale$beauty > 1,]

a <- c(nrow(trmale), nrow(trfemale))
b <- c(nrow(trm3), nrow(trf3))

prop.test(b,a)

## 
##  2-sample test for equality of proportions with continuity correction
## 
## data:  b out of a
## X-squared = 7.5674, df = 1, p-value = 0.005943
## alternative hypothesis: two.sided
## 95 percent confidence interval:
##  -0.16698250 -0.02406228
## sample estimates:
##    prop 1    prop 2 
## 0.1044776 0.2000000

Kết quả của kiểm định cho thấy sự khác biệt đáng kể về tỷ lệ giữa hai nhóm (Nam và Nữ) với mức ý nghĩa (p-value) là 0.005943, giá trị này thấp hơn mức ý nghĩa thông thường là 0.05. Điều này cho thấy có đủ bằng chứng để bác bỏ giả thuyết \(H_0\) có sự khác biệt giữa hai tỷ lệ.

Kết quả này cũng cung cấp một khoảng tin cậy 95% cho sự khác biệt giữa hai tỷ lệ, từ -0.16698250 đến -0.02406228. Điều này ngụ ý rằng tỷ lệ của nam có thể thấp hơn tỷ lệ của nữ, với mức độ khác biệt dự kiến nằm trong khoảng này.

Cụ thể, ước lượng tỷ lệ mẫu cho nhóm 1 (Nam) là 0.1044776 và cho nhóm 2 (Nữ) là 0.2. Điều này cho thấy rằng tỷ lệ của nhóm 2 (Nữ) có chỉ số ngoại hình cao hơn đáng kể so với tỷ lệ của nhóm 1 (Nam).

5. Ước lượng Relative Risk (Relative Risk/ Risk Ratio)

Ký hiệu \(\pi_i\) đại diện cho tỷ lệ “thành công” của biến phụ thuộc (response variable) tương ứng với từng biểu hiện của biến độc lập.

Từ bảng tần xuất, chúng ta tính tỷ lệ \(\frac{\pi_1}{\pi_2}\), phân số này Relative risk giữa 2 biểu hiện khác nhau của biến phụ thuộc.

Em quy đổi Giảng viên nào có chỉ số beauty từ -2 đến 1 sẽ được mã hoá thành “bình thường”, từ 1 trở lên sẽ được mã hoá thành “cao” để tiện cho việc đánh giá và sử dụng ước lượng Relative Risk

d$rankbeauty <- ifelse(d$beauty > 1, "cao", "bình thường")
tr <- table(d$gender, d$rankbeauty)
addmargins(tr)

##      
##       bình thường cao Sum
##   Nam         240  28 268
##   Nữ          156  39 195
##   Sum         396  67 463

Chúng ta tính rủi ro tương đối (Relative risk)

RelRisk(tr) 

## [1] 1.119403

riskratio(tr)

## $data
##        
##         bình thường cao Total
##   Nam           240  28   268
##   Nữ            156  39   195
##   Total         396  67   463
## 
## $measure
##      risk ratio with 95% C.I.
##       estimate    lower    upper
##   Nam 1.000000       NA       NA
##   Nữ  1.914286 1.221743 2.999395
## 
## $p.value
##      two-sided
##        midp.exact fisher.exact  chi.square
##   Nam          NA           NA          NA
##   Nữ  0.004467103  0.004826839 0.003918305
## 
## $correction
## [1] FALSE
## 
## attr(,"method")
## [1] "Unconditional MLE & normal approximation (Wald) CI"

riskratio(tr, rev = 'c')

## $data
##        
##         cao bình thường Total
##   Nam    28         240   268
##   Nữ     39         156   195
##   Total  67         396   463
## 
## $measure
##      risk ratio with 95% C.I.
##        estimate     lower    upper
##   Nam 1.0000000        NA       NA
##   Nữ  0.8933333 0.8236424 0.968921
## 
## $p.value
##      two-sided
##        midp.exact fisher.exact  chi.square
##   Nam          NA           NA          NA
##   Nữ  0.004467103  0.004826839 0.003918305
## 
## $correction
## [1] FALSE
## 
## attr(,"method")
## [1] "Unconditional MLE & normal approximation (Wald) CI"

## Câu lệnh này sẽ cung cấp nhiều thông tin hơn và thuận tiện hơn
## khi chúng ta biết thêm khái niệm oddratio trong phần tiếp theo
epitab(tr, method = 'riskratio', rev = 'c')

## $tab
##      
##       cao        p0 bình thường        p1 riskratio     lower    upper
##   Nam  28 0.1044776         240 0.8955224 1.0000000        NA       NA
##   Nữ   39 0.2000000         156 0.8000000 0.8933333 0.8236424 0.968921
##      
##           p.value
##   Nam          NA
##   Nữ  0.004826839
## 
## $measure
## [1] "wald"
## 
## $conf.level
## [1] 0.95
## 
## $pvalue
## [1] "fisher.exact"

Trong trường hợp này, giá trị 1.119403 cho thấy rằng xác suất một người có ngoại hình được đánh giá là cao trong nhóm nữ cao hơn 1.119 lần so với nam. Điều này có nghĩa là giới tính có ảnh hưởng đến đánh giá ngoại hình.

Từ bảng trên, ta có thể thấy rằng tỉ lệ phần trăm những người có ngoại hình được đánh giá là cao trong nhóm nam là 28/268 và trong nhóm nữ là 39/195. Khi so sánh hai tỉ lệ này, chúng ta có được giá trị rủi ro tương đối.

6. Tỷ lệ chênh (Odd Ratio)

Nếu gọi xác suất “thành công” của biểu hiện thứ \(i\) của biến độc lập là \(\pi_i\) thì chúng ta kí hiệu Tỷ lệ cược (odd) của biểu hiện này là \(\text{odd}_i\) và được định nghĩa như sau: \[ \text{odd}_i = \frac{\pi_i}{1 - \pi_i} \] Nghĩa là chúng ta tính tỷ lệ thành công theo từng hàng trong bảng ngẫu nhiên.

Tỷ lệ chênh của biểu hiện thứ \(i\) và biểu hiện thứ \(j\) được kí hiệu là \(\theta_{ij}\) và được định nghĩa: \[ \theta_{ij} = \frac{\text{odd}_i}{\text{odd}_j} = \frac{\pi_i (1 - \pi_j)}{\pi_j (1 - \pi_i)} \]

Ví dụ chúng sẽ tính odd cho bảng ngẫu nhiên sau với “thành công” chúng ta hiểu là được đánh giá ngoại hình cao.

trr <- table(d$gender, d$rankbeauty)
trr

##      
##       bình thường cao
##   Nam         240  28
##   Nữ          156  39

OddsRatio(trr)

## [1] 2.142857

Kết quả từ hàm OddsRatio cho thấy Odds Ratio là 2.142857.

• Odds Ratio (Tỷ lệ chênh) là một thước đo thống kê thể hiện khả năng xảy ra của một sự kiện so với khả năng không xảy ra của sự kiện đó, giữa hai nhóm khác nhau. Trong trường hợp này, chúng ta so sánh tỷ lệ giữa hai nhóm: nam và nữ, liên quan đến đánh giá ngoại hình là “cao”.

• Odds Ratio = 2.142857 có nghĩa là khả năng một người nữ được đánh giá là có ngoại hình “cao” cao hơn khoảng 2.14 lần so với một người nam.

• Odds của một sự kiện là tỷ lệ giữa khả năng xảy ra sự kiện đó và khả năng không xảy ra sự kiện đó. Ví dụ, nếu khả năng xảy ra một sự kiện là 0.2 (20%), thì odds của sự kiện đó là 0.2 / (1 - 0.2) = 0.25.

• Odds Ratio so sánh odds của sự kiện giữa hai nhóm. Odds Ratio > 1 cho thấy sự kiện đó có khả năng xảy ra cao hơn ở nhóm so với nhóm còn lại. Ngược lại, Odds Ratio < 1 cho thấy sự kiện đó có khả năng xảy ra thấp hơn ở nhóm so với nhóm còn lại.

• Kết quả Odds Ratio cho thấy rằng nữ giới có khả năng được đánh giá là có ngoại hình “cao” cao hơn nam giới. Cụ thể, nữ giới có khả năng được đánh giá cao hơn khoảng 2.14 lần so với nam giới.

• Kết quả này cung cấp một cái nhìn sâu hơn về mối quan hệ giữa giới tính và đánh giá ngoại hình, cho thấy rằng nữ giới có lợi thế hơn trong việc được đánh giá cao hơn về ngoại hình so với nam giới.

oddsratio(trr)

## $data
##        
##         bình thường cao Total
##   Nam           240  28   268
##   Nữ            156  39   195
##   Total         396  67   463
## 
## $measure
##      odds ratio with 95% C.I.
##       estimate    lower    upper
##   Nam 1.000000       NA       NA
##   Nữ  2.136096 1.265164 3.649184
## 
## $p.value
##      two-sided
##        midp.exact fisher.exact  chi.square
##   Nam          NA           NA          NA
##   Nữ  0.004467103  0.004826839 0.003918305
## 
## $correction
## [1] FALSE
## 
## attr(,"method")
## [1] "median-unbiased estimate & mid-p exact CI"

##Khi có thêm tham số rev = 'c' thì sẽ thực hiện việc
## đổi chỗ 2 cột trong bảngngẫu nhiên.
oddsratio(trr, rev = 'c') #package epitools

## $data
##        
##         cao bình thường Total
##   Nam    28         240   268
##   Nữ     39         156   195
##   Total  67         396   463
## 
## $measure
##      odds ratio with 95% C.I.
##        estimate     lower     upper
##   Nam 1.0000000        NA        NA
##   Nữ  0.4681376 0.2740339 0.7904113
## 
## $p.value
##      two-sided
##        midp.exact fisher.exact  chi.square
##   Nam          NA           NA          NA
##   Nữ  0.004467103  0.004826839 0.003918305
## 
## $correction
## [1] FALSE
## 
## attr(,"method")
## [1] "median-unbiased estimate & mid-p exact CI"

epitab(trr, method = 'oddsratio')

## $tab
##      
##       bình thường        p0 cao        p1 oddsratio    lower    upper
##   Nam         240 0.6060606  28 0.4179104  1.000000       NA       NA
##   Nữ          156 0.3939394  39 0.5820896  2.142857 1.266775 3.624825
##      
##           p.value
##   Nam          NA
##   Nữ  0.004826839
## 
## $measure
## [1] "wald"
## 
## $conf.level
## [1] 0.95
## 
## $pvalue
## [1] "fisher.exact"

# Tạo bảng tần suất chéo giữa gender và beauty_rank
gender_beauty_table <- table(TeachingRatings$gender, TeachingRatings$beauty_rank)

# Thực hiện kiểm định Chi-squared
chi_squared_test <- chisq.test(gender_beauty_table)

# Hiển thị kết quả
chi_squared_test

## 
##  Pearson's Chi-squared test
## 
## data:  gender_beauty_table
## X-squared = 10.969, df = 3, p-value = 0.0119