Có thể đáng để thêm một ví dụ khác, có lẽ đơn giản hơn vào câu trả lời xuất sắc của Stephen.
T| D ⊖ ~ N( μ-, σ2)T| D ⊕ ~ N( μ+, σ2).
pD ⊕ ∼ B e r n ( p )
bb⎛⎝⎜T⊕T⊖D ⊕p ( 1 - Φ+( b ) )p Φ+( b )D ⊖( 1 - p ) ( 1 - Φ-( b ) )( 1 - p ) Φ-( b )⎞⎠⎟.
Cách tiếp cận dựa trên độ chính xác
p ( 1 - Φ+( B ) ) + ( 1 - p ) Φ-(b),
b1πσ2−−−−√- p φ+( B ) + φ-( B ) - p φ-( b ) = 0e- ( b - μ-)22 σ2[ ( 1 - p ) - p e- 2 b ( μ-- μ+) + ( μ2+- μ2-)2 σ2] =0
( 1 - p ) - p e- 2 b ( μ-- μ+) + ( μ2+- μ2-)2 σ2= 0- 2 b ( μ-- μ+) + ( μ2+- μ2-)2 σ2= nhật ký1 - pp2 b ( μ+- μ-) + ( μ2-- μ2+)=2σ2log1−pp
b∗=(μ2+−μ2−)+2σ2log1−pp2(μ+−μ−)=μ++μ−2+σ2μ+−μ−log1−pp.
Lưu ý rằng điều này - tất nhiên - không phụ thuộc vào chi phí.
Nếu các lớp được cân bằng, tối ưu là trung bình của các giá trị thử nghiệm trung bình ở người ốm và người khỏe mạnh, nếu không, nó bị thay thế dựa trên sự mất cân bằng.
Phương pháp dựa trên chi phí
c++p(1−Φ+(b))+c−+(1−p)(1−Φ−(b))+c+−pΦ+(b)+c−−(1−p)Φ−(b).
b−c++pφ+(b)−c−+(1−p)φ−(b)+c+−pφ+(b)+c−−(1−p)φ−(b)==φ+(b)p(c+−−c++)+φ−(b)(1−p)(c−−−c−+)==φ+(b)pc+d−φ−(b)(1−p)c−d=0,
c+d=c+−−c++ and c−d=c−+−c−−.
The optimal threshold is therefore given by the solution of the equation φ+(b)φ−(b)=(1−p)c−dpc+d.
Two things should be noted here:
- This results is totally generic and works for any distribution of the test results, not only normal. (φ in that case of course means the probability density function of the distribution, not the normal density.)
- Whatever the solution for b is, it is surely a function of (1−p)c−dpc+d. (I.e., we immediately see how costs matter - in addition to class imbalance!)
I'd be really interested to see if this equation has a generic solution for b (parametrized by the φs), but I would be surprised.
Nevertheless, we can work it out for normal! 2πσ2−−−−√s cancel on the left hand side, so we have e−12((b−μ+)2σ2−(b−μ−)2σ2)=(1−p)c−dpc+d(b−μ−)2−(b−μ+)2=2σ2log(1−p)c−dpc+d2b(μ+−μ−)+(μ2−−μ2+)=2σ2log(1−p)c−dpc+d
therefore the solution is b∗=(μ2+−μ2−)+2σ2log(1−p)c−dpc+d2(μ+−μ−)=μ++μ−2+σ2μ+−μ−log(1−p)c−dpc+d.
(Compare it the the previous result! We see that they are equal if and only if c−d=c+d, i.e. the differences in misclassification cost compared to the cost of correct classification is the same in sick and healthy people.)
A short demonstration
Let's say c−−=0 (it is quite natural medically), and that c++=1 (we can always obtain it by dividing the costs with c++, i.e., by measuring every cost in c++ units). Let's say that the prevalence is p=0.2. Ngoài ra, hãy nói rằngμ-= 9,5, μ+= 10,5 và σ= 1.
Trong trường hợp này:
library( data.table )
library( lattice )
cminusminus <- 0
cplusplus <- 1
p <- 0.2
muminus <- 9.5
muplus <- 10.5
sigma <- 1
res <- data.table( expand.grid( b = seq( 6, 17, 0.1 ),
cplusminus = c( 1, 5, 10, 50, 100 ),
cminusplus = c( 2, 5, 10, 50, 100 ) ) )
res$cost <- cplusplus*p*( 1-pnorm( res$b, muplus, sigma ) ) +
res$cplusminus*(1-p)*(1-pnorm( res$b, muminus, sigma ) ) +
res$cminusplus*p*pnorm( res$b, muplus, sigma ) +
cminusminus*(1-p)*pnorm( res$b, muminus, sigma )
xyplot( cost ~ b | factor( cminusplus ), groups = cplusminus, ylim = c( -1, 22 ),
data = res, type = "l", xlab = "Threshold",
ylab = "Expected overall cost", as.table = TRUE,
abline = list( v = (muplus+muminus)/2+
sigma^2/(muplus-muminus)*log((1-p)/p) ),
strip = strip.custom( var.name = expression( {"c"^{"+"}}["-"] ),
strip.names = c( TRUE, TRUE ) ),
auto.key = list( space = "right", points = FALSE, lines = TRUE,
title = expression( {"c"^{"-"}}["+"] ) ),
panel = panel.superpose, panel.groups = function( x, y, col.line, ... ) {
panel.xyplot( x, y, col.line = col.line, ... )
panel.points( x[ which.min( y ) ], min( y ), pch = 19, col = col.line )
} )
Kết quả là (các điểm mô tả chi phí tối thiểu và đường thẳng đứng hiển thị ngưỡng tối ưu với cách tiếp cận dựa trên độ chính xác):
Chúng ta có thể thấy rất tốt cách tối ưu dựa trên chi phí có thể khác với tối ưu dựa trên độ chính xác. Bạn nên suy nghĩ về lý do tại sao: nếu việc phân loại một người bệnh sai lầm khỏe mạnh sẽ tốn kém hơn so với cách khác (c+- cao, c-+ là thấp) so với ngưỡng đi xuống, vì chúng tôi muốn phân loại dễ dàng hơn vào loại bệnh, mặt khác, nếu việc phân loại một người khỏe mạnh bị bệnh nhầm hơn so với cách khác là tốn kém hơn (c+- chậm, c-+là cao) so với ngưỡng tăng lên, vì chúng tôi muốn phân loại dễ dàng hơn vào danh mục lành mạnh. (Kiểm tra những cái này trên hình!)
Một ví dụ thực tế
Chúng ta hãy xem xét một ví dụ thực nghiệm, thay vì dẫn xuất lý thuyết. Ví dụ này về cơ bản sẽ khác nhau từ hai khía cạnh:
- Thay vì giả định tính quy tắc, chúng tôi sẽ chỉ sử dụng dữ liệu theo kinh nghiệm mà không có bất kỳ giả định nào như vậy.
- Thay vì sử dụng một thử nghiệm duy nhất và kết quả của nó trong các đơn vị riêng của mình, chúng tôi sẽ sử dụng một số thử nghiệm (và kết hợp chúng với hồi quy logistic). Ngưỡng sẽ được đưa ra xác suất dự đoán cuối cùng. Đây thực sự là cách tiếp cận ưa thích, xem Chương 19 - Chẩn đoán - trong BBR của Frank Harrell .
Bộ dữ liệu ( acathtừ gói Hmisc) là từ Databank Bệnh tim mạch của Đại học Duke, và chứa liệu bệnh nhân có bị bệnh mạch vành đáng kể hay không, như được đánh giá bằng thông tim, đây sẽ là tiêu chuẩn vàng của chúng tôi, tức là tình trạng bệnh thật và "xét nghiệm" "Sẽ là sự kết hợp giữa tuổi, giới tính, mức cholesterol và thời gian xuất hiện của đối tượng:
library( rms )
library( lattice )
library( latticeExtra )
library( data.table )
getHdata( "acath" )
acath <- acath[ !is.na( acath$choleste ), ]
dd <- datadist( acath )
options( datadist = "dd" )
fit <- lrm( sigdz ~ rcs( age )*sex + rcs( choleste ) + cad.dur, data = acath )
Đáng để vạch ra các rủi ro dự đoán theo thang đo logit, để xem mức độ bình thường của chúng (về cơ bản, đó là những gì chúng tôi đã giả định trước đây, với một thử nghiệm duy nhất!):
densityplot( ~predict( fit ), groups = acath$sigdz, plot.points = FALSE, ref = TRUE,
auto.key = list( columns = 2 ) )
Chà, họ hầu như không bình thường ...
Hãy tiếp tục và tính toán chi phí tổng thể dự kiến:
ExpectedOverallCost <- function( b, p, y, cplusminus, cminusplus,
cplusplus = 1, cminusminus = 0 ) {
sum( table( factor( p>b, levels = c( FALSE, TRUE ) ), y )*matrix(
c( cminusminus, cplusminus, cminusplus, cplusplus ), nc = 2 ) )
}
table( predict( fit, type = "fitted" )>0.5, acath$sigdz )
ExpectedOverallCost( 0.5, predict( fit, type = "fitted" ), acath$sigdz, 2, 4 )
Và hãy vẽ nó cho tất cả các chi phí có thể (một lưu ý tính toán: chúng ta không cần phải lặp đi lặp lại một cách vô thức qua các số từ 0 đến 1, chúng ta có thể xây dựng lại đường cong một cách hoàn hảo bằng cách tính toán cho tất cả các giá trị duy nhất của xác suất dự đoán):
ps <- sort( unique( c( 0, 1, predict( fit, type = "fitted" ) ) ) )
xyplot( sapply( ps, ExpectedOverallCost,
p = predict( fit, type = "fitted" ), y = acath$sigdz,
cplusminus = 2, cminusplus = 4 ) ~ ps, type = "l", xlab = "Threshold",
ylab = "Expected overall cost", panel = function( x, y, ... ) {
panel.xyplot( x, y, ... )
panel.points( x[ which.min( y ) ], min( y ), pch = 19, cex = 1.1 )
panel.text( x[ which.min( y ) ], min( y ), round( x[ which.min( y ) ], 3 ),
pos = 3 )
} )
Chúng ta có thể thấy rất rõ nơi chúng ta nên đặt ngưỡng để tối ưu hóa chi phí chung dự kiến (không sử dụng độ nhạy, độ đặc hiệu hoặc giá trị dự đoán ở bất cứ đâu!). Đây là cách tiếp cận chính xác.
Điều đặc biệt là hướng dẫn để đối chiếu các số liệu này:
ExpectedOverallCost2 <- function( b, p, y, cplusminus, cminusplus,
cplusplus = 1, cminusminus = 0 ) {
tab <- table( factor( p>b, levels = c( FALSE, TRUE ) ), y )
sens <- tab[ 2, 2 ] / sum( tab[ , 2 ] )
spec <- tab[ 1, 1 ] / sum( tab[ , 1 ] )
c( `Expected overall cost` = sum( tab*matrix( c( cminusminus, cplusminus, cminusplus,
cplusplus ), nc = 2 ) ),
Sensitivity = sens,
Specificity = spec,
PPV = tab[ 2, 2 ] / sum( tab[ 2, ] ),
NPV = tab[ 1, 1 ] / sum( tab[ 1, ] ),
Accuracy = 1 - ( tab[ 1, 1 ] + tab[ 2, 2 ] )/sum( tab ),
Youden = 1 - ( sens + spec - 1 ),
Topleft = ( 1-sens )^2 + ( 1-spec )^2
)
}
ExpectedOverallCost2( 0.5, predict( fit, type = "fitted" ), acath$sigdz, 2, 4 )
res <- melt( data.table( ps, t( sapply( ps, ExpectedOverallCost2,
p = predict( fit, type = "fitted" ),
y = acath$sigdz,
cplusminus = 2, cminusplus = 4 ) ) ),
id.vars = "ps" )
p1 <- xyplot( value ~ ps, data = res, subset = variable=="Expected overall cost",
type = "l", xlab = "Threshold", ylab = "Expected overall cost",
panel=function( x, y, ... ) {
panel.xyplot( x, y, ... )
panel.abline( v = x[ which.min( y ) ],
col = trellis.par.get()$plot.line$col )
panel.points( x[ which.min( y ) ], min( y ), pch = 19 )
} )
p2 <- xyplot( value ~ ps, groups = variable,
data = droplevels( res[ variable%in%c( "Expected overall cost",
"Sensitivity",
"Specificity", "PPV", "NPV" ) ] ),
subset = variable%in%c( "Sensitivity", "Specificity", "PPV", "NPV" ),
type = "l", xlab = "Threshold", ylab = "Sensitivity/Specificity/PPV/NPV",
auto.key = list( columns = 3, points = FALSE, lines = TRUE ) )
doubleYScale( p1, p2, use.style = FALSE, add.ylab2 = TRUE )
Bây giờ chúng ta có thể phân tích các số liệu đôi khi được quảng cáo cụ thể là có thể đưa ra mức cắt tối ưu mà không phải trả chi phí, và tương phản với phương pháp dựa trên chi phí của chúng tôi! Hãy sử dụng ba số liệu thường được sử dụng nhất:
- Độ chính xác (tối đa hóa độ chính xác)
- Quy tắc Youden (tối đa hóa Se n s + Sp e c - 1)
- Quy tắc Topleft (tối thiểu hóa ( 1 - Se n s )2+ ( 1 - Sp e c )2)
(Để đơn giản, chúng tôi sẽ trừ các giá trị trên từ 1 cho quy tắc Youden và Chính xác để chúng tôi có vấn đề tối thiểu hóa ở mọi nơi.)
Hãy xem kết quả:
p3 <- xyplot( value ~ ps, groups = variable,
data = droplevels( res[ variable%in%c( "Expected overall cost", "Accuracy",
"Youden", "Topleft" ) ] ),
subset = variable%in%c( "Accuracy", "Youden", "Topleft" ),
type = "l", xlab = "Threshold", ylab = "Accuracy/Youden/Topleft",
auto.key = list( columns = 3, points = FALSE, lines = TRUE ),
panel = panel.superpose, panel.groups = function( x, y, col.line, ... ) {
panel.xyplot( x, y, col.line = col.line, ... )
panel.abline( v = x[ which.min( y ) ], col = col.line )
panel.points( x[ which.min( y ) ], min( y ), pch = 19, col = col.line )
} )
doubleYScale( p1, p3, use.style = FALSE, add.ylab2 = TRUE )
Tất nhiên điều này liên quan đến một cấu trúc chi phí cụ thể, c--= 0, c++= 1, c-+= 2, c+-= 4(điều này rõ ràng chỉ quan trọng đối với quyết định chi phí tối ưu). Để nghiên cứu ảnh hưởng của cấu trúc chi phí, chúng ta chỉ chọn ngưỡng tối ưu (thay vì theo dõi toàn bộ đường cong), nhưng vẽ nó như là một hàm của chi phí. Cụ thể hơn, như chúng ta đã thấy, ngưỡng tối ưu phụ thuộc vào bốn chi phí chỉ thông quac-d/ c+d tỷ lệ, vì vậy, hãy vẽ biểu đồ cắt tối ưu là một chức năng của điều này, cùng với các số liệu thường được sử dụng không sử dụng chi phí:
res2 <- data.frame( rat = 10^( seq( log10( 0.02 ), log10( 50 ), length.out = 500 ) ) )
res2$OptThreshold <- sapply( res2$rat,
function( rat ) ps[ which.min(
sapply( ps, Vectorize( ExpectedOverallCost, "b" ),
p = predict( fit, type = "fitted" ),
y = acath$sigdz,
cplusminus = rat,
cminusplus = 1,
cplusplus = 0 ) ) ] )
xyplot( OptThreshold ~ rat, data = res2, type = "l", ylim = c( -0.1, 1.1 ),
xlab = expression( {"c"^{"-"}}["d"]/{"c"^{"+"}}["d"] ), ylab = "Optimal threshold",
scales = list( x = list( log = 10, at = c( 0.02, 0.05, 0.1, 0.2, 0.5, 1,
2, 5, 10, 20, 50 ) ) ),
panel = function( x, y, resin = res[ ,.( ps[ which.min( value ) ] ),
.( variable ) ], ... ) {
panel.xyplot( x, y, ... )
panel.abline( h = resin[variable=="Youden"] )
panel.text( log10( 0.02 ), resin[variable=="Youden"], "Y", pos = 3 )
panel.abline( h = resin[variable=="Accuracy"] )
panel.text( log10( 0.02 ), resin[variable=="Accuracy"], "A", pos = 3 )
panel.abline( h = resin[variable=="Topleft"] )
panel.text( log10( 0.02 ), resin[variable=="Topleft"], "TL", pos = 1 )
} )
Các đường nằm ngang chỉ ra các cách tiếp cận không sử dụng chi phí (và do đó không đổi).
Một lần nữa, chúng tôi thấy rằng chi phí phân loại sai trong nhóm khỏe mạnh tăng lên so với nhóm bệnh, ngưỡng tối ưu tăng: nếu chúng tôi thực sự không muốn những người khỏe mạnh được phân loại là bệnh, chúng tôi sẽ sử dụng mức cắt cao hơn (và cách khác xung quanh, tất nhiên!).
Và cuối cùng, chúng ta lại thấy một lần nữa tại sao những phương pháp không sử dụng chi phí lại không ( và không thể! ) Luôn luôn tối ưu.
