Bayes correlation Hot Hot Hot Hot

Bài toán này có thể được giải quyết theo 2 cách thông thường là: 1 hệ số tương quan r của Pearson và 2 hồi quy tuyến tính đơn biến Mục tiêu của bài này : Thay thế cả 2 phương pháp trên b

Lê Đông Nhật Nam

data=read.csv("http://vincentarelbundock.github.io/Rdatasets/csv/Ecdat/VietNamH.csv")

data=data[,c(8,9)]

data=na.omit(data)

data=subset(data,lntotal>0 & lnmed>0)

attach(data)

Nguồn dữ liệu: Vietnam World Bank Livings Standards Survey

Chú thích : dataset này khảo sát chi phí y tế của 5999 hộ gia đình tại Việt Nam năm 1997, chúng ta trích xuất 2 biến số là lnmed (response variable), chi phí y tế được logarit hóa, và lntotal = thu nhập trong 12 tháng (cũng được logatir hóa).

Để giảm cỡ mẫu, chúng ta loại bỏ tất cả case có giá trị explanatory va response variable = 0 hoặc = NA

Data cuối cùng còn lại 5004 trường hợp.

Câu hỏi cần giải quyết được giả định là : Khảo sát mối liên hệ giữa chi phí y tế và thu nhập bình quân ?

Bài toán này có thể được giải quyết theo 2 cách thông thường là: (1) hệ số tương quan r của Pearson và (2) hồi quy tuyến tính đơn biến

Mục tiêu của bài này : Thay thế cả 2 phương pháp trên bằng phương pháp BAYES

Dẫn nhập và số liệu

ggplot(data,aes(x=lnmed))+geom_density(fill="deeppink1",alpha=0.5)+theme_light(base_size=20)

transparent_theme = theme(

axis.title.x = element_blank(),

axis.title.y = element_blank(),

axis.text.x = element_blank(),

axis.text.y = element_blank(),

axis.ticks = element_blank(),

panel.grid = element_blank(),

axis.line = element_blank(),

panel.background = element_rect(fill = "transparent",colour = NA),

plot.background = element_rect(fill = "transparent",colour = NA))

xmin =min(lntotal); xmax =max(lntotal)

ymin =min(lnmed); ymax =max(lnmed)

scatterPlot=ggplot(data,aes(lntotal,lnmed))+geom_point(alpha=0.2,color="deeppink1")+geom_smooth(method="lm",color="deeppink4",fill="gold",al pha=0.6)

px=ggplot(data,aes(factor(1),lntotal))+geom_boxplot(width=0.2,fill="gold")+coord_flip()+transparent_theme

py=ggplot(data,aes(factor(1),lnmed))+geom_boxplot(width=0.1,fill="gold")+transparent_theme

px_grob = ggplotGrob(px)

py_grob = ggplotGrob(py)

scatterPlot+annotation_custom(grob = px_grob, xmin = xmin, xmax = xmax,ymin = ymin-1.5, ymax = ymin+1.5)+annotation_custom(grob =

py_grob,xmin = xmin-1.5, xmax = xmin+1.5,ymin = ymin, ymax = ymax)+theme_light(base_size=20)

Thăm dò trực quan mối liên hệ tuyến tính Y ~ X

Đây là phân phối của response variable: lnmed

Nó rất giống một phân phối t-student

Vấn đề chính gây trở ngại ở đây là outliers, rất nhiều outliers…

Thăm dò trực quan mối liên

hệ tuyến tính Y ~ X

2 Dự báo và nhận xét ban đầu

Những dự báo và nhận xét ban đầu:

+ Giữa lnmed và lntotal chắc chắn có tương quan tuyến tính, dù rất yếu nhưng mô hình tuyến tính và hệ số

Pearson’s r sẽ có ý nghĩa (Vì cỡ mẫu quá lớn)

+ Phương pháp cổ điển (Pearson, least square regression) se bị giới hạn, không chính xác hoàn toàn, vì chúng đều

dựa trên giả định là lnmed có phân phối Gaussian, trong khi đó data có rất nhiều outliers

+ Giải pháp chính xác và toàn diện phải dựa vào phân phối t-student của Y, tương đương với một mô hình GLM với family=student-t và dự báo cho cả 3 tham số: Mu, sigma và Nu

Pearson

GLM, phân phối student

Least square linear regression

Thứ gọi là hệ số tương quan r

Bayes

Giải pháp linh hoạt và triệt để nhất

Không sợ outliers, bất chấp outliers và kiểu phân phối của Y Dựa vào GLM, mô tả tất cả tham số của phân phối Student t Prior biến hóa tùy ý thích

Phân phối hậu nghiệm, Suy diễn không dùng giả thuyết 0

corr= cor.test(lntotal,lnmed)

corr

Pearson's product-moment correlation data: lntotal and lnmed

t = 17.784, df = 5002, p-value < 2.2e-16

alternative hypothesis: true correlation is not equal to 0

95 percent confidence interval:

0.2176193 0.2697427

sample estimates:

cor

0.2438571

(corr$estimate)^2

cor

0.0594663

mg=glm(lnmed~lntotal,family=gaussian) summary.lm(mg)

Call:

glm(formula = lnmed ~ lntotal, family = gaussian)

Residuals:

Min 1Q Median 3Q Max -6.4450 -0.9499 0.1034 1.0609 5.4595 Coefficients:

Estimate Std Error t value Pr(>|t|) (Intercept) 0.91834 0.30414 3.019 0.00254 **

lntotal 0.57573 0.03237 17.784 < 2e-16 ***

-Signif codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1 Residual standard error: 1.541 on 5002 degrees of freedom Multiple R-squared: 0.05947, Adjusted R-squared: 0.05928 F-statistic: 316.3 on 1 and 5002 DF, p-value: < 2.2e-16

AIC(mg) [1] 18529.9

Cách thứ 1: Đi tìm thứ gọi là hệ số tương quan Pearson

Pearson’s r chính là một trường hợp đặc biệt của 𝑅2 Dựa vào mô hình hồi quy tuyến tính Y ~X

require(gamlss)

mt=gamlss(data=data,formula=lnmed~lntotal,sigma.formula=~lntotal,nu.formula=

~lntotal,family=TF)

summary(mt)

Family: c("TF", "t Family")

Call:

gamlss(formula = lnmed ~ lntotal, sigma.formula = ~lntotal, nu.formula = ~lntotal,

family = TF, data = data)

Fitting method: RS()

-Mu link function: identity

Mu Coefficients:

Estimate Std Error t value Pr(>|t|)

(Intercept) 1.23862 0.29898 4.143 3.49e-05 ***

lntotal 0.54169 0.03232 16.762 < 2e-16 ***

-Signif codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

-Sigma link function: log

Sigma Coefficients:

Estimate Std Error t value Pr(>|t|)

(Intercept) -0.95404 0.16105 -5.924 3.35e-09 ***

lntotal 0.14611 0.01701 8.592 < 2e-16 ***

-Signif codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

-Nu link function: log

Nu Coefficients:

Estimate Std Error t value Pr(>|t|) (Intercept) 3.5218 8.6520 0.407 0.684

lntotal 0.1420 0.9245 0.154 0.878

-No of observations in the fit: 5004 Degrees of Freedom for the fit: 6 Residual Deg of Freedom: 4998

at cycle: 12

Global Deviance: 18434.87 AIC: 18446.87 SBC: 18485.97

************************************************

Cách thứ 2: Mô tả phân phối Student-t của Y bằng mọi giá…

data$pred=predict(mt,type="response") cor.test(data$pred,lnmed)

Pearson's product-moment correlation data: data$pred and lnmed

t = 17.784, df = 5002, p-value < 2.2e-16 alternative hypothesis: true correlation is not equal to 0

95 percent confidence interval:

0.2176193 0.2697427 sample estimates:

cor

0.2438571

(cor(data$pred,lnmed))^2

[1] 0.0594663

Như đã nói ở trên, cả Pearson r và mô hình glm đều có nguy cơ bị ảnh hưởng bởi outlier, giải pháp tổng quát nhất là sử dụng phân phối Student T cho Y thay vì Gaussian

Để dựng một mô hình Student t, ta phải dùng tới package gamlss

Kết quả cho thấy không chỉ Mu mà sigma của Y cũng phụ thuộc vào X, trong khi Nu không bị ảnh hưởng và AIC thì thấp hơn

Từ mô hình này ta cũng có thể tính R2 và 1 hệ số r giả = hệ số tương quan giữa giá trị dự báo và thực tế của Y

Giá trị Y : phân phối Student t

𝝁

sigma Gamma Exponential

Giá trị Intercept

𝝁𝟐

𝝁𝟏

Phân phối Gaussian (𝝁𝟏,sd1)

Phân phối Gaussian (𝝁2,sd2)

Giá trị beta 1

uniform

𝒀 ~ 𝒃𝟎 + 𝒃𝟏 ∗ 𝑿

Prior

Cơ chế của phân tích hồi quy tuyến tính theo Bayes :

Response variable Y được giả định có phân phối t Student với 3 tham số Mu,sigma và Nu

Prior (phân phối tiền định) của 3 tham số này lần lượt là:

Mu ~ Intercept + b1.X, với Intercept và beta1 có prior = gaussian

Nu có prior = Gamma hoặc Exponential (hằng định)

Sigma có prior = Student t (nếu phụ thuộc X) hoặc Uniform (hằng định)

Một mô hình sẽ được thiết lập để dự báo Mu,sigma và Nu của Y theo X

Phân phối hậu nghiệm được xác định bằng

Markov Chain Monte Carlo

Student t

Cách thứ 3: chúng ta đón con tàu Bayes để đi theo lộ trình hoàn toàn khác

Inference for Stan model: student(identity) brms-model.

4 chains, each with iter=1500; warmup=500; thin=1;

post-warmup draws per chain=1000, total post-warmup draws=4000.

mean se_mean sd 2.5% 25% 50% 75% 97.5%

b_Intercept 0.88 0.01 0.30 0.29 0.68 0.88 1.08 1.45

b_lntotal 0.58 0.00 0.03 0.52 0.56 0.58 0.60 0.64

sigma_lnmed 1.49 0.00 0.02 1.45 1.48 1.49 1.51 1.53

nu 36.07 0.31 12.35 19.35 27.23 33.62 42.23 66.55

lp -6394.02 0.04 1.40 -6397.57 -6394.70 -6393.70 -6392.97 -6392.27

n_eff Rhat b_Intercept 2202 1

b_lntotal 2188 1

sigma_lnmed 1866 1

nu 1627 1

lp 1390 1

require(brms) require(coda) set.seed(123)

rstan_options(auto_write = TRUE) options(mc.cores = parallel::detectCores())

prior1=get_prior(data=data,formula=lnmed~lntotal,family=student) prior1

prior class coef group nlpar bound

1 b

2 b Intercept

3 b lntotal

4 Intercept

5 gamma(2, 0.1) nu

6 student_t(3, 0, 10) sigma

7 sigma lnmed

bayesm1=brm(data=data,formula=lnmed~lntotal,family=student,prior=prior1,chains=4,warmup=500,iter=1500)

plot(bayesm1) bayesm1$fit

Sử dụng package brms

Brms là 1 giao thức rất tiện dụng kết nối 1 model và một MCMC

sampler (ở đây dùng STAN) Từ version 0,9, brms còn có thể chạy song

song trên nhiều core CPU (tối đa 4 core trên PC Intel i5 hoặc i7)

Trước hết, bạn có thể xác định prior tự động bằng hàm get_prior, hoặc

thiết kế prior cho riêng mình

Sau đó nhập nội dung model như sau:

Kết quả do brms xuất ra cho ta phân phối hậu nghiệm của 4 tham số:

Intercept của Y, beta của X, sigma của Y, Nu của Y…

7 1 Phân phối hậu nghiệm

Hypothesis Tests for class b:

Estimate Est.Error l-99% CI u-99% CI Evid.Ratio lntotal-(0.5) > 0 0.08 0.03 0.01 Inf 209.53 *

-'*': The expected value under the hypothesis lies outside the 99% CI

hypothesis(bayesm1,"lntotal<0.65",alpha=0.01)

Hypothesis Tests for class b:

Estimate Est.Error l-99% CI u-99% CI Evid.Ratio lntotal-(0.65) < 0 -0.07 0.03 -Inf 0 62.49

-'*': The expected value under the hypothesis lies outside the 99% CI

Diễn giải:

Mỗi đơn vị log(thu nhập cả năm) tăng sẽ làm log(chi phí y tế) tăng trung

bình 0,58 đơn vị Tỉ lệ này gần như chắc chắn cao hơn 0,5(Bayes Factor =

209,5, p value<0,01)

Bayes Factor

Bayes Factor

7 2 Kiểm định giả thuyết H1 với Bayes Factor

Đường thẳng hồi quy của mô hình Bayes

SE của mô hình Bayes

7 3 Marginal effect của model…

8 Tạo hàm phân tích khoảng vô nghĩa thực dụng (ROPE)

và ngưỡng ý nghĩa (compVal)

HDIofMCMC= function( sampleVec , credMass=0.95 ) {

sortedPts = sort( sampleVec )

ciIdxInc = ceiling( credMass * length( sortedPts ) )

nCIs = length( sortedPts ) - ciIdxInc

ciWidth = rep( 0 , nCIs )

for ( i in 1:nCIs ) {

ciWidth[ i ] = sortedPts[ i + ciIdxInc ] - sortedPts[ i ]

}

HDImin = sortedPts[ which.min( ciWidth ) ]

HDImax = sortedPts[ which.min( ciWidth ) + ciIdxInc ]

HDIlim = c( HDImin , HDImax )

return( HDIlim )

}

Bước 1: Tạo hàm HDIofMCMC:

Công dụng : Xác định khoảng mật độ cao nhất (HDI95%) của phân phối hậu nghiệm

Hàm này sẽ được sử dụng trong quá trình khảo sát phân phối hậu nghiệm của Intercept, Beta, Sigma và Nu

Ghi chú: Trích nguyên văn từ source code của JOHN K KRUSCHKE

Hàm này có thể tái sử dụng cho bất cứ model nào

Bản thân package brms không cho phép khảo sát khoảng vô nghĩa thực dụng (ROPE) và ngưỡng ý nghĩa (CompVal) theo như ý tưởng của J.Kruschke

Nhận thấy rằng ROPE và Compval rất hữu ích, nên mình bổ sung thêm 1 số hàm cho phép tích hợp phân tích ROPE và CompVal vào kết quả do brms xuất ra

Phương pháp J.Kruschke áp dụng trên output thuộc lớp MCMC và dựa vào 1 vài hàm trong package coda, nên trước tiên bạn cần install package coda Mình sửa lại source code của Kruschke để có thể áp dụng trực tiếp trên kết quả brms (vốn không tương thích với coda).

summarizePost=function(paramSampleVec ,

compVal=NULL , ROPE=NULL , credMass=0.95 ) {

meanParam = mean( paramSampleVec )

medianParam = median( paramSampleVec )

dres = density( paramSampleVec )

modeParam = dres$x[which.max(dres$y)]

mcmcEffSz = round( effectiveSize( paramSampleVec ) , 1 )

names(mcmcEffSz) = NULL

hdiLim = HDIofMCMC( paramSampleVec , credMass=credMass )

if ( !is.null(compVal) ) {

pcgtCompVal = ( 100 * sum( paramSampleVec > compVal )

/ length( paramSampleVec ) )

} else {

compVal=NA

pcgtCompVal=NA

}

if ( !is.null(ROPE) ) {

pcltRope = ( 100 * sum( paramSampleVec < ROPE[1] )

/ length( paramSampleVec ) )

pcgtRope = ( 100 * sum( paramSampleVec > ROPE[2] )

/ length( paramSampleVec ) )

pcinRope = 100-(pcltRope+pcgtRope)

} else {

ROPE = c(NA,NA)

pcltRope=NA

pcgtRope=NA

pcinRope=NA

}

return( c( Mean=meanParam , Median=medianParam , Mode=modeParam ,

ESS=mcmcEffSz ,

HDImass=credMass , HDIlow=hdiLim[1] , HDIhigh=hdiLim[2] ,

CompVal=compVal , PcntGtCompVal=pcgtCompVal ,

ROPElow=ROPE[1] , ROPEhigh=ROPE[2] ,

PcntLtROPE=pcltRope , PcntInROPE=pcinRope , PcntGtROPE=pcgtRope ) )

}

Bước 2: Tạo hàm summarizePost

Công dụng : Tính tỉ lệ % quan sát trong phân phối hậu nghiệm (chuỗi MCMC) rơi vào trong khoảng vô nghĩa thực dụng (ROPE) cũng như nằm ngoài ngưỡng ý nghĩa

Hàm này cũng sẽ được sử dụng trong quá trình khảo sát phân phối hậu nghiệm của Intercept, Beta, Sigma và Nu

Ghi chú: Trích nguyên văn từ source code của JOHN K KRUSCHKE

Hàm này có thể tái sử dụng cho bất cứ model nào

8 Tạo hàm phân tích khoảng vô nghĩa thực dụng (ROPE)

và ngưỡng ý nghĩa (compVal)

summaryBRMS=function(model,

compValBeta0=NULL , ropeBeta0=NULL ,

compValBeta1=NULL , ropeBeta1=NULL ,

compValSigma=NULL , ropeSigma=NULL ,

compValNu=NULL , ropeNu=NULL)

{

summaryInfo = NULL

mcmcvector=as.mcmc(model)

mcmcMat = as.matrix(mcmcvector,chains=TRUE)

summaryInfo = rbind(summaryInfo ,

"Intercept" = summarizePost( mcmcMat[,"b_Intercept"] ,

compVal=compValBeta0 , ROPE=ropeBeta0 ) ) summaryInfo = rbind(summaryInfo ,

"b1" = summarizePost(mcmcMat[,"b_lntotal"] ,

compVal=compValBeta1 , ROPE=ropeBeta1 ) ) summaryInfo = rbind(summaryInfo ,

"Sigma" = summarizePost(mcmcMat[,"sigma_lnmed"],

compVal=compValSigma , ROPE=ropeSigma ) )

summaryInfo = rbind(summaryInfo ,

"Nu" = summarizePost(mcmcMat[,"nu"] ,

compVal=compValNu , ROPE=ropeNu ) )

return(summaryInfo)

}

8 Tạo hàm phân tích khoảng vô nghĩa thực dụng (ROPE)

và ngưỡng ý nghĩa (compVal)

Bước 3 : Tạo hàm summaryBRMS

Công dụng : Khi áp dụng hàm này trực tiếp cho 1 đối tượng mô hình thuộc lớp brms; kèm theo tùy chọn về các giá trị của ROPE và comVal; thì kết quả được xuất ra sẽ bao gồm 3 phần:

1) Mean Median Mode ESS HDImass HDIlow HDIhigh (trung bình, trung vị, Mode, Error sum of squares, mật độ HDI (mặc định =95%) 2) CompVal PcntGtCompVal ROPElow ROPEhigh PcntLtROPE PcntInROPE PcntGtROPE

(CompVal = ngưỡng ý nghĩa cần so sánh, ROPElow,high = khoảng vô nghĩa thực dụng

PcntInRope, PcntGtROPE: tỉ lệ % quan sát rơi vào trong khoảng vô nghĩa (càng cao càng xấu), và nằm ngoài khoảng này (càng cao càng tốt) Tương tự: PcntGtCompVal: % quan sát nằm ngoài (lớn hơn) ngưỡng ý nghĩa (càng cao càng tốt)

Những kết quả này hiển thị cho cả 4 tham số trong mô hình: Intercept, Beta, Sigma và Nu

Ghi chú: Hàm summaryBRMS được cải biên lại đôi chút từ hàm sumamryMCMC của JOHN K KRUSCHKE, ở đây mình viết thêm 1 vài đoạn code để tương thích với kết quả thuộc lớp brms.

Lưu ý: Hàm này chỉ có thể áp dụng cho mô hình tuyến tính đơn biến VÀ trước khi sử dụng, bạn cần chỉnh sửa nội dung những dòng chữ màu đỏ cho phù hợp với tên các biến số, tham số có trong model brms của riêng mình

Dĩ nhiên với model nhiều tham số hơn, bạn chỉ cần chèn thêm các nhóm summaryInfo và thêm argument trong function(…)