Câu trả lời:
Vâng, bạn có thể.
Mô hình là
Khi không khác, giá trị này có cực trị toàn cầu tại . x = - β 1 / ( 2 β 2 )
Hồi quy logistic ước tính các hệ số này là . Bởi vì đây là một ước tính tối đa khả năng (và ML ước tính của các chức năng của các tham số là những chức năng tương tự của dự toán), chúng tôi có thể ước tính vị trí của cực trị là .- b 1 / ( 2 b 2 )
Một khoảng tin cậy cho ước tính đó sẽ được quan tâm. Đối với các bộ dữ liệu đủ lớn để áp dụng lý thuyết khả năng tối đa tiệm cận, chúng ta có thể tìm thấy các điểm cuối của khoảng này bằng cách thể hiện lại dưới dạng
và tìm bao nhiêu 1 - α / 2 có thể thay đổi trước khi khả năng đăng nhập giảm quá nhiều. "Quá nhiều" là, không có triệu chứng, một nửa số lượng tử của phân phối chi bình phương với một bậc tự do.
Cách tiếp cận này sẽ hoạt động tốt với điều kiện phạm vi bao trùm cả hai phía của đỉnh và có đủ số và phản hồi trong số các giá trị để phân định đỉnh đó. Mặt khác, vị trí của cực đại sẽ không chắc chắn và các ước tính tiệm cận có thể không đáng tin cậy.
R
mã để thực hiện điều này là dưới đây. Nó có thể được sử dụng trong một mô phỏng để kiểm tra mức độ bao phủ của các khoảng tin cậy gần với phạm vi bảo hiểm dự định. Lưu ý cách đỉnh thực sự là và - bằng cách nhìn vào hàng dưới cùng của biểu đồ - làm thế nào hầu hết các giới hạn độ tin cậy thấp hơn giá trị thực và hầu hết các giới hạn tin cậy trên đều lớn hơn giá trị thực, như chúng ta hy vọng Trong ví dụ này, phạm vi bảo hiểm dự định là và phạm vi bảo hiểm thực tế (chiết khấu bốn trong số trường hợp hồi quy logistic không hội tụ) là , cho thấy phương pháp này hoạt động tốt (đối với các loại dữ liệu được mô phỏng đây).
n <- 50 # Number of observations in each trial
beta <- c(-1,2,2) # Coefficients
x <- seq(from=-3, to=3, length.out=n)
y0 <- cbind(rep(1,length(x)), x, x^2) %*% beta
# Conduct a simulation.
set.seed(17)
sim <- replicate(500, peak(x, rbinom(length(x), 1, logistic(y0)), alpha=0.05))
# Post-process the results to check the actual coverage.
tp <- -beta[2] / (2 * beta[3])
covers <- sim["lcl",] <= tp & tp <= sim["ucl",]
mean(covers, na.rm=TRUE) # Should be close to 1 - 2*alpha
# Plot the distributions of the results.
par(mfrow=c(2,2))
plot(x, logistic(y0), type="l", lwd=2, col="#4040d0", main="Simulated Data",ylim=c(0,1))
points(x, rbinom(length(x), 1, logistic(y0)), pch=19)
hist(sim["peak.x",], main="Estimates"); abline(v=tp, col="Red")
hist(sim["lcl",], main="Lower Confidence Limits"); abline(v=tp, col="Red")
hist(sim["ucl",], main="Upper Confidence Limits"); abline(v=tp, col="Red")
logistic <- function(x) 1 / (1 + exp(-x))
peak <- function(x, y, alpha=0.05) {
#
# Estimate the peak of a quadratic logistic fit of y to x
# and a 1-alpha confidence interval for that peak.
#
logL <- function(b) {
# Log likelihood.
p <- sapply(cbind(rep(1, length(x)), x, x*x) %*% b, logistic)
sum(log(p[y==1])) + sum(log(1-p[y==0]))
}
f <- function(gamma) {
# Deviance as a function of offset from the peak.
b0 <- c(b[1] - b[2]^2/(4*b[3]) + b[3]*gamma^2, -2*b[3]*gamma, b[3])
-2.0 * logL(b0)
}
# Estimation.
fit <- glm(y ~ x + I(x*x), family=binomial(link = "logit"))
if (!fit$converged) return(rep(NA,3))
b <- coef(fit)
tp <- -b[2] / (2 * b[3])
# Two-sided confidence interval:
# Search for where the deviance is at a threshold determined by alpha.
delta <- qchisq(1-alpha, df=1)
u <- sd(x)
while(fit$deviance - f(tp+u) + delta > 0) u <- 2*u # Find an upper bound
l <- sd(x)
while(fit$deviance - f(tp-l) + delta > 0) l <- 2*l # Find a lower bound
upper <- uniroot(function(gamma) fit$deviance - f(gamma) + delta,
interval=c(tp, tp+u))
lower <- uniroot(function(gamma) fit$deviance - f(gamma) + delta,
interval=c(tp-l, tp))
# Return a vector of the estimate, lower limit, and upper limit.
c(peak=tp, lcl=lower$root, ucl=upper$root)
}