Cách đánh giá dự đoán của bạn Hãy lưu tâm đến biện pháp bạn chọn | của Jeffrey Näf | Tháng 5 năm 2024

Hãy chú ý đến biện pháp bạn chọn

TViệc đánh giá và đo điểm chuẩn các mô hình học máy bằng cách so sánh dự đoán của chúng trên một tập thử nghiệm, ngay cả sau khi triển khai, có tầm quan trọng cơ bản. Để làm được điều này người ta cần phải nghĩ ra biện pháp hoặc điểm lấy dự đoán và điểm kiểm tra rồi gán giá trị đo lường mức độ thành công của dự đoán đối với điểm kiểm tra. Tuy nhiên, người ta nên suy nghĩ cẩn thận về cách tính điểm nào là phù hợp. Đặc biệt, khi lựa chọn một phương pháp để đánh giá một dự đoán, chúng ta nên tuân theo ý tưởng quy tắc tính điểm phù hợp. Tôi chỉ đưa ra một định nghĩa lỏng lẻo về ý tưởng này ở đây, nhưng về cơ bản, chúng tôi muốn một điểm số được giảm thiểu ở thứ chúng tôi muốn đo!

BẰNG một quy tắc chung: Người ta có thể sử dụng MSE để đánh giá các dự đoán trung bình, MAE để đánh giá các dự đoán trung bình, điểm lượng tử để đánh giá các dự đoán lượng tử tổng quát hơn và điểm năng lượng hoặc MMD để đánh giá các dự đoán phân phối.

Hãy xem xét một biến bạn muốn dự đoán, chẳng hạn như một biến ngẫu nhiên Ytừ một vectơ đồng biến X. Trong ví dụ dưới đây, Y sẽ là thu nhập và X sẽ có những đặc điểm nhất định, chẳng hạn như tuổi Và giáo dục. Chúng tôi đã học được một dự đoán f trên một số dữ liệu đào tạo và bây giờ chúng tôi dự đoán Y BẰNG f(x). Thông thường, khi chúng ta muốn dự đoán một biến Y tốt nhất có thể, chúng tôi dự đoán kỳ vọng của y được cho xI E f(x) nên xấp xỉ E(Y | X=x). Nhưng tổng quát hơn, f(x) có thể là một công cụ ước tính của trung vị, các lượng tử khác hoặc thậm chí là phân phối có điều kiện đầy đủ P(Y | X=x).

Bây giờ là điểm kiểm tra mới ychúng tôi muốn chấm điểm dự đoán của bạn, tức là bạn muốn có một hàm S(y,f(x))đó là giảm thiểu (Trong kỳ vọng) khi f(x) là điều tốt nhất bạn có thể làm. Ví dụ, nếu chúng ta muốn dự đoán E(Y | X=x)điểm này được đưa ra dưới dạng MSE: S(y,f(x))= (yf(x))².

Ở đây chúng ta nghiên cứu nguyên tắc tính điểm của yếu tố dự đoán f ở tập thử nghiệm của (y_i,x_i), i=1,…,ntest chi tiết hơn. Trong tất cả các ví dụ, chúng tôi sẽ so sánh phương pháp ước tính lý tưởng với một phương pháp khác rõ ràng là sai hoặc ngây thơ và cho thấy rằng điểm số của chúng tôi làm đúng những gì chúng được cho là.

Ví dụ

Để minh họa mọi thứ, tôi sẽ mô phỏng một tập dữ liệu đơn giản mô phỏng dữ liệu thu nhập. Chúng tôi sẽ sử dụng ví dụ đơn giản này trong suốt bài viết này để minh họa các khái niệm.

library(dplyr)
#Create some variables:
# Simulate knowledge for 100 people
n <- 5000
# Generate age between 20 and 60
age <- spherical(runif(n, min = 20, max = 60))
# Outline schooling ranges
education_levels <- c("Excessive Faculty", "Bachelor's", "Grasp's")
# Simulate schooling degree chances
education_probs <- c(0.4, 0.4, 0.2)
# Pattern schooling degree primarily based on chances
schooling <- pattern(education_levels, n, change = TRUE, prob = education_probs)
# Simulate expertise correlated with age with some random error
expertise <- age - 20 + spherical(rnorm(n, imply = 0, sd = 3)) 
# Outline a non-linear operate for wage
wage <- exp((age * 0.1) + (case_when(schooling == "Excessive Faculty" ~ 1,
schooling == "Bachelor's" ~ 1.5,
TRUE ~ 2)) + (expertise * 0.05) + rnorm(n, imply = 0, sd = 0.5))
hist(wage)

Mặc dù mô phỏng này có thể được đơn giản hóa quá mức, nhưng nó phản ánh một số đặc điểm nổi tiếng nhất định của dữ liệu đó: tuổi lớn hơn, trình độ học vấn cao hơn và kinh nghiệm nhiều hơn đều có liên quan đến mức lương cao hơn. Việc sử dụng toán tử “exp” dẫn đến phân phối tiền lương có độ lệch cao, đây là một quan sát nhất quán trong các bộ dữ liệu như vậy.

Điều quan trọng là sự sai lệch này cũng xuất hiện khi chúng ta gắn tuổi tác, trình độ học vấn và kinh nghiệm vào những giá trị nhất định. Hãy tưởng tượng chúng ta nhìn vào một người cụ thể, Dave, 30 tuổi, có bằng Cử nhân Kinh tế và 10 năm kinh nghiệm và hãy xem phân bổ thu nhập thực tế của anh ta theo quy trình tạo dữ liệu của chúng ta:

ageDave<-30
educationDave<-"Bachelor's"
experienceDave <- 10
wageDave <- exp((ageDave * 0.1) + (case_when(educationDave == "Excessive Faculty" ~ 1,
educationDave == "Bachelor's" ~ 1.5,
TRUE ~ 2)) + (experienceDave * 0.05) + rnorm(n, imply = 0, sd = 0.5))
hist(wageDave, major="Wage Distribution for Dave", xlab="Wage")

Do đó, việc phân bổ tiền lương có thể có của Dave, dựa trên thông tin chúng tôi có về anh ấy, vẫn rất sai lệch.

Chúng tôi cũng tạo một bộ thử nghiệm gồm một số người:

## Generate take a look at set
ntest<-1000
# Generate age between 20 and 60
agetest <- spherical(runif(ntest, min = 20, max = 60))
# Pattern schooling degree primarily based on chances
educationtest <- pattern(education_levels, ntest, change = TRUE, prob = education_probs)
# Simulate expertise correlated with age with some random error
experiencetest <- agetest - 20 + spherical(rnorm(ntest, imply = 0, sd = 3))
## Generate ytest that we attempt to predict:
wagetest <- exp((agetest * 0.1) + (case_when(educationtest == "Excessive Faculty" ~ 1,
educationtest == "Bachelor's" ~ 1.5,
TRUE ~ 2)) + (experiencetest * 0.05) + rnorm(ntest, imply = 0, sd = 0.5))

Bây giờ chúng ta bắt đầu đơn giản và trước tiên hãy xem xét điểm số cho dự đoán trung bình và trung bình.

Điểm số cho dự đoán trung bình và trung bình

Trong khoa học dữ liệu và học máy, sự quan tâm thường tập trung vào một số duy nhất biểu thị “trung tâm” hoặc “giữa” phân phối mà chúng ta muốn dự đoán, cụ thể là giá trị trung bình (có điều kiện) hoặc trung vị. Để làm điều này, chúng ta có sai số bình phương trung bình (MSE):

và sai số tuyệt đối trung bình (MAE):

Một điểm quan trọng cần rút ra là MSE là thước đo thích hợp để dự đoán giá trị trung bình có điều kiện, trong khi MAE là thước đo được sử dụng cho giá trị trung bình có điều kiện. Giá trị trung bình và trung vị không giống nhau đối với các phân phối lệch như phân phối chúng ta nghiên cứu ở đây.

Hãy để chúng tôi minh họa điều này cho ví dụ trên bằng các công cụ ước tính rất đơn giản (mà chúng tôi sẽ không có quyền truy cập trong đời thực), chỉ để minh họa:

conditionalmeanest <-
operate(age, schooling, expertise, N = 1000) {
imply(exp((age * 0.1) + (
case_when(
schooling == "Excessive Faculty" ~ 1,
schooling == "Bachelor's" ~ 1.5,
TRUE ~ 2
)
) + (expertise * 0.05) + rnorm(N, imply = 0, sd = 0.5)
))
}
conditionalmedianest <-
operate(age, schooling, expertise, N = 1000) {
median(exp((age * 0.1) + (
case_when(
schooling == "Excessive Faculty" ~ 1,
schooling == "Bachelor's" ~ 1.5,
TRUE ~ 2
)
) + (expertise * 0.05) + rnorm(N, imply = 0, sd = 0.5)
))
}

Đó là chúng tôi ước tính giá trị trung bình và trung vị, bằng cách mô phỏng đơn giản từ mô hình cho các giá trị cố định về độ tuổi, trình độ học vấn và kinh nghiệm (đây sẽ là mô phỏng từ phân phối có điều kiện chính xác) và sau đó chúng tôi chỉ cần lấy giá trị trung bình/trung vị của điều đó. Hãy kiểm tra điều này trên Dave:

hist(wageDave, major="Wage Distribution for Dave", xlab="Wage")
abline(v=conditionalmeanest(ageDave, educationDave, experienceDave), col="darkred", cex=1.2)
abline(v=conditionalmedianest(ageDave, educationDave, experienceDave), col="darkblue", cex=1.2)

Rõ ràng giá trị trung bình và trung vị là khác nhau, như người ta mong đợi từ sự phân bổ như vậy. Trên thực tế, như điển hình cho phân phối thu nhập, giá trị trung bình cao hơn (bị ảnh hưởng nhiều hơn bởi các giá trị cao) so với giá trị trung bình.

Bây giờ hãy sử dụng các công cụ ước tính này trên bộ thử nghiệm:

Xtest<-data.body(age=agetest, schooling=educationtest, expertise=experiencetest)
meanest<-sapply(1:nrow(Xtest), operate(j)  conditionalmeanest(Xtest$age(j), Xtest$schooling(j), Xtest$expertise(j))  )
median<-sapply(1:nrow(Xtest), operate(j)  conditionalmedianest(Xtest$age(j), Xtest$schooling(j), Xtest$expertise(j))  )

Điều này mang lại một loạt các giá trị trung bình/trung bình có điều kiện. Bây giờ chúng tôi tính toán MSE và MAE:

(MSE1<-mean((meanest-wagetest)^2))
(MSE2<-mean((median-wagetest)^2))
MSE1 < MSE2
### Methodology 1 (the true imply estimator) is healthier than methodology 2!
# however the MAE is definitely worse of methodology 1!
(MAE1<-mean(abs(meanest-wagetest)) )
(MAE2<-mean( abs(median-wagetest)))
MAE1 < MAE2
### Methodology 2 (the true median estimator) is healthier than methodology 1!

Điều này cho thấy những gì đã biết về mặt lý thuyết: MSE được giảm thiểu cho kỳ vọng (có điều kiện) E(Y | X=x)trong khi MAE được giảm thiểu ở mức trung bình có điều kiện. Nói chung, sẽ không có ý nghĩa gì khi sử dụng MAE khi bạn cố gắng đánh giá dự đoán trung bình của mình. Trong nhiều nghiên cứu ứng dụng và khoa học dữ liệu, mọi người sử dụng MAE hoặc cả hai để đánh giá các dự đoán trung bình (tôi biết vì tôi đã tự mình làm điều đó). Mặc dù điều này có thể được đảm bảo trong một số ứng dụng nhất định, nhưng điều này có thể gây ra hậu quả nghiêm trọng đối với các phân bố không đối xứng, như chúng ta đã thấy trong ví dụ này: Khi xem xét MAE, phương pháp 1 có vẻ kém hơn phương pháp 2, mặc dù phương pháp trước ước tính giá trị trung bình chính xác . Trên thực tế, trong ví dụ rất sai lệch này, phương pháp 1 phải có MAE thấp hơn phương pháp 2.

Để tính điểm dự đoán trung bình có điều kiện, hãy sử dụng sai số bình phương trung bình (MSE) chứ không phải sai số tuyệt đối trung bình (MAE). MAE được giảm thiểu cho trung vị có điều kiện.

Điểm cho dự đoán lượng tử và khoảng

Giả sử chúng ta muốn ghi điểm ước tính f(x) của lượng tử q_x như vậy mà

Trong trường hợp này, chúng ta có thể xem xét điểm lượng tử:

theo đó

Để giải nén công thức này, chúng ta có thể xem xét hai trường hợp:

(1) y nhỏ hơn f(x):

tức là chúng ta phải chịu một hình phạt càng lớn hơn y là từ f(x).

(2) y lớn hơn f(x):

tức là hình phạt càng lớn thì càng đi xa y là từ f(x).

Lưu ý rằng trọng lượng là như vậy đối với mức cao alphacó lượng tử ước tính f(x) nhỏ hơn y bị phạt nhiều hơn. Điều này là do thiết kế và đảm bảo rằng lượng tử phù hợp thực sự là giá trị nhỏ nhất của giá trị kỳ vọng của S(y,f(x)) hơn y. Điểm số này thực chất là mất lượng tử (tối đa hệ số 2), xem ví dụ này bài viết hay. Nó được triển khai trong quantile_score chức năng của gói tiện ích ghi điểm trong R. Cuối cùng, lưu ý rằng đối với alpha=0,5:

đơn giản là MAE! Điều này có ý nghĩa vì lượng tử 0,5 là trung vị.

Với khả năng dự đoán lượng tử, chúng ta cũng có thể xây dựng các khoảng dự đoán. Coi như (tôi _xbạn_x)Ở đâu tôi _x ≤ bạn_x là các lượng tử sao cho

Trong thực tế, điều này được đáp ứng nếu tôi _x là các alpha/2 lượng tử, và bạn_x là 1-alpha/2 lượng tử. Vì vậy, bây giờ chúng tôi ước tính và cho điểm hai phân vị này. Coi như f(x)=(f_1(x), f_2(x))nhờ đó f_1(x) là ước tính của tôi _x Và f_2(x) ước tính của bạn_x. Chúng tôi cung cấp hai công cụ ước tính, một công cụ ước tính “lý tưởng” mô phỏng lại từ quy trình thực tế để ước tính các lượng tử cần thiết và một công cụ ước tính “ngây thơ”, có phạm vi bao phủ phù hợp nhưng quá lớn:

library(scoringutils)
## Outline conditional quantile estimation
conditionalquantileest <-
operate(probs, age, schooling, expertise, N = 1000) {
quantile(exp((age * 0.1) + (
case_when(
schooling == "Excessive Faculty" ~ 1,
schooling == "Bachelor's" ~ 1.5,
TRUE ~ 2
)
) + (expertise * 0.05) + rnorm(N, imply = 0, sd = 0.5)
)
, probs =
probs)
}
## Outline a really naive estimator that can nonetheless have the required protection
lowernaive <- 0
uppernaive <- max(wage)
# Outline the quantile of curiosity
alpha <- 0.05
decrease <-
sapply(1:nrow(Xtest), operate(j)
conditionalquantileest(alpha / 2, Xtest$age(j), Xtest$schooling(j), Xtest$expertise(j)))
higher <-
sapply(1:nrow(Xtest), operate(j)
conditionalquantileest(1 - alpha / 2, Xtest$age(j), Xtest$schooling(j), Xtest$expertise(j)))
## Calculate the scores for each estimators
# 1. Rating the alpha/2 quantile estimate
qs_lower <- imply(quantile_score(wagetest,
predictions = decrease,
quantiles = alpha / 2))
# 2. Rating the alpha/2 quantile estimate
qs_upper <- imply(quantile_score(wagetest,
predictions = higher,
quantiles = 1 - alpha / 2))
# 1. Rating the alpha/2 quantile estimate
qs_lowernaive <- imply(quantile_score(wagetest,
predictions = rep(lowernaive, ntest),
quantiles = alpha / 2))
# 2. Rating the alpha/2 quantile estimate
qs_uppernaive <- imply(quantile_score(wagetest,
predictions = rep(uppernaive, ntest),
quantiles = 1 - alpha / 2))
# Assemble the interval rating by taking the common
(interval_score <- (qs_lower + qs_upper) / 2)
# Rating of the best estimator: 187.8337
# Assemble the interval rating by taking the common
(interval_scorenaive <- (qs_lowernaive + qs_uppernaive) / 2)
# Rating of the naive estimator: 1451.464

Một lần nữa, chúng ta có thể thấy rõ rằng, trung bình, người ước tính đúng có điểm thấp hơn nhiều so với người ước lượng ngây thơ!

Do đó, với điểm số lượng tử, chúng ta có một cách đáng tin cậy để ghi điểm dự đoán lượng tử riêng lẻ. Tuy nhiên, cách tính trung bình điểm của các lượng tử trên và dưới trong khoảng dự đoán có vẻ đặc biệt. Might mắn thay, hóa ra điều này dẫn đến cái gọi là điểm ngắt quãng:

Do đó, thông qua một số phép thuật đại số, chúng ta có thể tính được khoảng dự đoán bằng cách lấy điểm trung bình cho alpha/2 và 1-alpha/2 lượng tử như chúng tôi đã làm. Điều thú vị là, điểm số theo khoảng thời gian thu được sẽ thưởng cho khoảng thời gian dự đoán hẹp và gây ra một hình phạt, mức độ của hình phạt này phụ thuộc vào alpha, nếu quan sát bỏ lỡ khoảng thời gian. Thay vì sử dụng điểm trung bình của các điểm phân vị, chúng ta cũng có thể tính trực tiếp điểm này bằng gói ghi điểmutils.

alpha <- 0.05
imply(interval_score(
wagetest,
decrease=decrease,
higher=higher,
interval_range=(1-alpha)*100,
weigh = T,
separate_results = FALSE
))
#Rating of the best estimator: 187.8337

Đây chính xác là con số mà chúng tôi nhận được ở trên khi tính trung bình điểm của hai khoảng thời gian.

Điểm lượng tử được triển khai trong R trong gói tính điểm có thể được sử dụng để chấm điểm các dự đoán lượng tử. Nếu muốn tính điểm trực tiếp cho khoảng dự đoán, có thể sử dụng hàm interval_score.

Điểm cho dự đoán phân phối

Ngày càng có nhiều lĩnh vực phải giải quyết dự đoán phân phối. Might mắn thay thậm chí còn có điểm cho vấn đề này. Đặc biệt, ở đây tôi tập trung vào cái được gọi là điểm năng lượng:

vì f(x) là ước tính của sự phân phối P(Y | X=x). Thuật ngữ thứ hai lấy kỳ vọng về khoảng cách Eucledian giữa hai mẫu độc lập từ f(x). Điều này giống như một thuật ngữ chuẩn hóa, thiết lập giá trị nếu so sánh cùng một phân bố. Thuật ngữ đầu tiên sau đó so sánh điểm mẫu y để hòa X từ f(x). Trong sự mong đợi (hơn Y vẽ từ P(Y | X=x)) điều này sẽ được giảm thiểu nếu f(x)=P(Y | X=x).

Do đó, thay vì chỉ dự đoán giá trị trung bình hoặc phân vị, giờ đây chúng tôi cố gắng dự đoán toàn bộ sự phân bổ tiền lương tại mỗi điểm kiểm tra. Về cơ bản, chúng tôi cố gắng dự đoán và đánh giá phân bố có điều kiện mà chúng tôi đã vẽ cho Dave ở trên. Điều này phức tạp hơn một chút; chính xác thì chúng ta biểu diễn một phân phối đã học như thế nào? Trong thực tế, điều này được giải quyết bằng cách giả sử chúng ta có thể lấy được mẫu từ phân bố dự đoán. Vì vậy, chúng tôi so sánh một mẫu của N, thu được từ phân phối dự đoán, đến một điểm kiểm tra duy nhất. Điều này có thể được thực hiện trong R bằng cách sử dụng es_sample từ ghi điểmQuy tắc bưu kiện:

library(scoringRules)
## Preferrred "estimate": Merely pattern from the true conditional distribution 
## P(Y | X=x) for every pattern level x
distributionestimate <-
operate(age, schooling, expertise, N = 100) {
exp((age * 0.1) + (
case_when(
schooling == "Excessive Faculty" ~ 1,
schooling == "Bachelor's" ~ 1.5,
TRUE ~ 2
)
) + (expertise * 0.05) + rnorm(N, imply = 0, sd = 0.5))
}
## Naive Estimate: Solely pattern from the error distribution, with out together with the 
## data of every particular person.
distributionestimatenaive <-
operate(age, schooling, expertise, N = 100) {
exp(rnorm(N, imply = 0, sd = 0.5))
}
scoretrue <- imply(sapply(1:nrow(Xtest), operate(j)  {
wageest <-
distributionestimate(Xtest$age(j), Xtest$schooling(j), Xtest$expertise(j))
return(scoringRules::es_sample(y = wagetest(j), dat = matrix(wageest, nrow=1)))
}))
scorenaive <- imply(sapply(1:nrow(Xtest), operate(j)  {
wageest <-
distributionestimatenaive(Xtest$age(j), Xtest$schooling(j), Xtest$expertise(j))
return(scoringRules::es_sample(y = wagetest(j), dat = matrix(wageest, nrow=1)))
}))
## scoretrue: 761.026
## scorenaive: 2624.713

Trong đoạn mã trên, chúng ta lại so sánh ước tính “hoàn hảo” (tức là lấy mẫu từ phân bố thực P(Y | X=x)) đến một người rất ngây thơ, cụ thể là người không xem xét bất kỳ thông tin nào về tiền lương, trình độ học vấn hoặc kinh nghiệm. Một lần nữa, điểm số xác định một cách đáng tin cậy phương pháp nào tốt hơn trong hai phương pháp.

Điểm năng lượng, được triển khai trong Quy tắc chấm điểm gói R, có thể được sử dụng để chấm điểm dự đoán phân phối, nếu có sẵn mẫu từ phân phối dự đoán.

Phần kết luận

Chúng tôi đã xem xét các cách khác nhau để dự đoán điểm. Suy nghĩ về thước đo phù hợp để kiểm tra các dự đoán là rất quan trọng, vì thước đo sai có thể khiến chúng ta chọn và giữ sai mô hình cho nhiệm vụ dự đoán của mình.

Cần lưu ý rằng đặc biệt đối với dự đoán phân phối, việc tính điểm này là một nhiệm vụ khó khăn và điểm số có thể không có nhiều tác dụng trong thực tế. Nghĩa là, ngay cả một phương pháp dẫn đến sự cải thiện lớn cũng có thể chỉ có số điểm nhỏ hơn một chút. Tuy nhiên, đây không phải là vấn đề, miễn là điểm số có thể xác định được phương pháp nào tốt hơn trong hai phương pháp một cách đáng tin cậy.

Người giới thiệu

(1) Tilmann Gneiting & Adrian E Raftery (2007) Quy tắc tính điểm, dự đoán và ước tính đúng đắn, Tạp chí của Hiệp hội Thống kê Hoa Kỳ, 102:477, 359–378, DOI: 10.1198/016214506000001437

Phụ lục: Tất cả mã ở một nơi

library(dplyr)
#Create some variables:
# Simulate knowledge for 100 people
n <- 5000
# Generate age between 20 and 60
age <- spherical(runif(n, min = 20, max = 60))
# Outline schooling ranges
education_levels <- c("Excessive Faculty", "Bachelor's", "Grasp's")
# Simulate schooling degree chances
education_probs <- c(0.4, 0.4, 0.2)
# Pattern schooling degree primarily based on chances
schooling <- pattern(education_levels, n, change = TRUE, prob = education_probs)
# Simulate expertise correlated with age with some random error
expertise <- age - 20 + spherical(rnorm(n, imply = 0, sd = 3)) 
# Outline a non-linear operate for wage
wage <- exp((age * 0.1) + (case_when(schooling == "Excessive Faculty" ~ 1,
schooling == "Bachelor's" ~ 1.5,
TRUE ~ 2)) + (expertise * 0.05) + rnorm(n, imply = 0, sd = 0.5))
hist(wage)
ageDave<-30
educationDave<-"Bachelor's"
experienceDave <- 10
wageDave <- exp((ageDave * 0.1) + (case_when(educationDave == "Excessive Faculty" ~ 1,
educationDave == "Bachelor's" ~ 1.5,
TRUE ~ 2)) + (experienceDave * 0.05) + rnorm(n, imply = 0, sd = 0.5))
hist(wageDave, major="Wage Distribution for Dave", xlab="Wage")
## Generate take a look at set
ntest<-1000
# Generate age between 20 and 60
agetest <- spherical(runif(ntest, min = 20, max = 60))
# Pattern schooling degree primarily based on chances
educationtest <- pattern(education_levels, ntest, change = TRUE, prob = education_probs)
# Simulate expertise correlated with age with some random error
experiencetest <- agetest - 20 + spherical(rnorm(ntest, imply = 0, sd = 3))
## Generate ytest that we attempt to predict:
wagetest <- exp((agetest * 0.1) + (case_when(educationtest == "Excessive Faculty" ~ 1,
educationtest == "Bachelor's" ~ 1.5,
TRUE ~ 2)) + (experiencetest * 0.05) + rnorm(ntest, imply = 0, sd = 0.5))
conditionalmeanest <-
operate(age, schooling, expertise, N = 1000) {
imply(exp((age * 0.1) + (
case_when(
schooling == "Excessive Faculty" ~ 1,
schooling == "Bachelor's" ~ 1.5,
TRUE ~ 2
)
) + (expertise * 0.05) + rnorm(N, imply = 0, sd = 0.5)
))
}
conditionalmedianest <-
operate(age, schooling, expertise, N = 1000) {
median(exp((age * 0.1) + (
case_when(
schooling == "Excessive Faculty" ~ 1,
schooling == "Bachelor's" ~ 1.5,
TRUE ~ 2
)
) + (expertise * 0.05) + rnorm(N, imply = 0, sd = 0.5)
))
}
hist(wageDave, major="Wage Distribution for Dave", xlab="Wage")
abline(v=conditionalmeanest(ageDave, educationDave, experienceDave), col="darkred", cex=1.2)
abline(v=conditionalmedianest(ageDave, educationDave, experienceDave), col="darkblue", cex=1.2)
Xtest<-data.body(age=agetest, schooling=educationtest, expertise=experiencetest)
meanest<-sapply(1:nrow(Xtest), operate(j)  conditionalmeanest(Xtest$age(j), Xtest$schooling(j), Xtest$expertise(j))  )
median<-sapply(1:nrow(Xtest), operate(j)  conditionalmedianest(Xtest$age(j), Xtest$schooling(j), Xtest$expertise(j))  )
(MSE1<-mean((meanest-wagetest)^2))
(MSE2<-mean((median-wagetest)^2))
MSE1 < MSE2
### Methodology 1 (the true imply estimator) is healthier than methodology 2!
# however the MAE is definitely worse of methodology 1!
(MAE1<-mean(abs(meanest-wagetest)) )
(MAE2<-mean( abs(median-wagetest)))
MAE1 < MAE2
### Methodology 2 (the true median estimator) is healthier than methodology 1!
library(scoringutils)
## Outline conditional quantile estimation
conditionalquantileest <-
operate(probs, age, schooling, expertise, N = 1000) {
quantile(exp((age * 0.1) + (
case_when(
schooling == "Excessive Faculty" ~ 1,
schooling == "Bachelor's" ~ 1.5,
TRUE ~ 2
)
) + (expertise * 0.05) + rnorm(N, imply = 0, sd = 0.5)
)
, probs =
probs)
}
## Outline a really naive estimator that can nonetheless have the required protection
lowernaive <- 0
uppernaive <- max(wage)
# Outline the quantile of curiosity
alpha <- 0.05
decrease <-
sapply(1:nrow(Xtest), operate(j)
conditionalquantileest(alpha / 2, Xtest$age(j), Xtest$schooling(j), Xtest$expertise(j)))
higher <-
sapply(1:nrow(Xtest), operate(j)
conditionalquantileest(1 - alpha / 2, Xtest$age(j), Xtest$schooling(j), Xtest$expertise(j)))
## Calculate the scores for each estimators
# 1. Rating the alpha/2 quantile estimate
qs_lower <- imply(quantile_score(wagetest,
predictions = decrease,
quantiles = alpha / 2))
# 2. Rating the alpha/2 quantile estimate
qs_upper <- imply(quantile_score(wagetest,
predictions = higher,
quantiles = 1 - alpha / 2))
# 1. Rating the alpha/2 quantile estimate
qs_lowernaive <- imply(quantile_score(wagetest,
predictions = rep(lowernaive, ntest),
quantiles = alpha / 2))
# 2. Rating the alpha/2 quantile estimate
qs_uppernaive <- imply(quantile_score(wagetest,
predictions = rep(uppernaive, ntest),
quantiles = 1 - alpha / 2))
# Assemble the interval rating by taking the common
(interval_score <- (qs_lower + qs_upper) / 2)
# Rating of the best estimator: 187.8337
# Assemble the interval rating by taking the common
(interval_scorenaive <- (qs_lowernaive + qs_uppernaive) / 2)
# Rating of the naive estimator: 1451.464
library(scoringRules)
## Preferrred "estimate": Merely pattern from the true conditional distribution 
## P(Y | X=x) for every pattern level x
distributionestimate <-
operate(age, schooling, expertise, N = 100) {
exp((age * 0.1) + (
case_when(
schooling == "Excessive Faculty" ~ 1,
schooling == "Bachelor's" ~ 1.5,
TRUE ~ 2
)
) + (expertise * 0.05) + rnorm(N, imply = 0, sd = 0.5))
}
## Naive Estimate: Solely pattern from the error distribution, with out together with the 
## data of every particular person.
distributionestimatenaive <-
operate(age, schooling, expertise, N = 100) {
exp(rnorm(N, imply = 0, sd = 0.5))
}
scoretrue <- imply(sapply(1:nrow(Xtest), operate(j)  {
wageest <-
distributionestimate(Xtest$age(j), Xtest$schooling(j), Xtest$expertise(j))
return(scoringRules::es_sample(y = wagetest(j), dat = matrix(wageest, nrow=1)))
}))
scorenaive <- imply(sapply(1:nrow(Xtest), operate(j)  {
wageest <-
distributionestimatenaive(Xtest$age(j), Xtest$schooling(j), Xtest$expertise(j))
return(scoringRules::es_sample(y = wagetest(j), dat = matrix(wageest, nrow=1)))
}))
## scoretrue: 761.026
## scorenaive: 2624.713