Làm thế nào để xấp xỉ yên ngựa làm việc?

Làm thế nào để xấp xỉ yên ngựa làm việc? Những loại vấn đề là nó tốt cho?
(Vui lòng sử dụng một ví dụ cụ thể hoặc ví dụ bằng cách minh họa)

Có bất kỳ nhược điểm, khó khăn, những điều cần chú ý, hoặc bẫy cho người không sẵn sàng?

Xấp xỉ xấp xỉ với hàm mật độ xác suất (nó hoạt động tương tự đối với các hàm khối lượng, nhưng tôi sẽ chỉ nói ở đây về mật độ) là một xấp xỉ hoạt động tốt đáng ngạc nhiên, có thể được xem như là một sàng lọc trên định lý giới hạn trung tâm. Vì vậy, nó sẽ chỉ hoạt động trong các cài đặt có định lý giới hạn trung tâm, nhưng nó cần các giả định mạnh hơn.

Chúng tôi bắt đầu với giả định rằng hàm tạo mô men tồn tại và có thể phân biệt hai lần. Điều này ngụ ý đặc biệt rằng tất cả các khoảnh khắc tồn tại. Đặt là biến ngẫu nhiên có hàm tạo mô men (mgf) và cgf (hàm tạo tích lũy) K (t) = \ log M (t) (trong đó \ log biểu thị logarit tự nhiên). Trong quá trình phát triển, tôi sẽ theo sát Ronald W Butler: "Khoảng cách gần đúng với các ứng dụng" (CUP). Chúng tôi sẽ phát triển xấp xỉ yên ngựa bằng cách sử dụng xấp xỉ Laplace đến một tích phân nhất định. Viết $X$

$$\DeclareMathOperator{\E}{\mathbb{E}} M(t) = \E e^{t X}$$ $K(t)=\log M(t)$$\log$ $$e^{K(t)} = \int_{-\infty}^\infty e^{t x} f(x) \; dx =\int_{-\infty}^\infty \exp(tx+\log f(x) ) \; dx \\ = \int_{-\infty}^\infty \exp(-h(t,x)) \; dx$$ trong đó $h(t,x) = -tx - \log f(x)$ . Bây giờ chúng ta sẽ Taylor mở rộng$h(t,x)$ trong$x$ coi$t$ là hằng số. Điều này cho $$h(t,x)=h(t,x_0) + h'(t,x_0)(x-x_0) +\frac12 h''(t,x_0) (x-x_0)^2 +\dotsm$$ trong đó$'$ biểu thị sự khác biệt đối với$x$ . Lưu ý rằng $$h'(t,x)=-t-\frac{\partial}{\partial x}\log f(x) \\ h''(t,x)= -\frac{\partial^2}{\partial x^2} \log f(x) > 0$$ (bất đẳng thức cuối cùng theo giả định vì nó cần thiết cho phép tính gần đúng hoạt động). Hãy để$x_t$là giải pháp cho $h'(t,x_t)=0$ . Chúng tôi sẽ giả sử rằng điều này cung cấp tối thiểu cho $h(t,x)$ là hàm của $x$ . Sử dụng phần mở rộng này trong tích phân và quên đi phần $\dotsm$ , mang lại cho $$e^{K(t)} \approx \int_{-\infty}^\infty \exp(-h(t,x_t)-\frac12 h''(t,x_t) (x-x_t)^2 ) \; dx \\ = e^{-h(t,x_t)} \int_{-\infty}^\infty e^{-\frac12 h''(t,x_t) (x-x_t)^2} \; dx$$ là tích phân Gaussian, cho $$e^{K(t)} \approx e^{-h(t,x_t)} \sqrt{\frac{2\pi}{h''(t,x_t)}}.$$ Điều này mang lại (một phiên bản đầu tiên) của xấp xỉ yên ngựa là $$f(x_t) \approx \sqrt{\frac{h''(t,x_t)}{2\pi}} \exp(K(t) -t x_t) \\ \tag{*} \label{*}$$ Lưu ý rằng phép tính gần đúng có dạng một gia đình hàm mũ.

Bây giờ chúng ta cần thực hiện một số công việc để có được điều này ở dạng hữu ích hơn.

Từ ta được Việc phân biệt điều này với cho (theo giả định của chúng tôi), vì vậy mối quan hệ giữa và là đơn điệu, vì vậy được xác định rõ. Chúng ta cần một xấp xỉ với . Cuối cùng, chúng tôi nhận được bằng cách giải quyết từ$h'(t,x_t)=0$

$$t = -\frac{\partial}{\partial x_t} \log f(x_t).$$ $x_t$ $$\frac{\partial t}{\partial x_t} = -\frac{\partial^2}{\partial x_t^2} \log f(x_t) > 0$$ $t$$x_t$$x_t$$\frac{\partial}{\partial x_t} \log f(x_t)$ log f ( x t ) = K ( t ) - t x t - 1$\eqref{*}$ $$\log f(x_t) = K(t) -t x_t -\frac12 \log \frac{2\pi}{-\frac{\partial^2}{\partial x_t^2} \log f(x_t)}. \tag{**} \label{**}$$ xtxt∂logf(xt) Giả sử thuật ngữ cuối cùng ở trên chỉ phụ thuộc yếu vào , do đó đạo hàm của nó đối với xấp xỉ bằng 0 (chúng tôi sẽ quay lại nhận xét về điều này), chúng tôi nhận được Tính đến gần đúng này, sau đó chúng ta có để và phải liên quan thông qua phương trình được gọi là phương trình yên ngựa. $x_t$$x_t$ $$\frac{\partial \log f(x_t)}{\partial x_t} \approx (K'(t)-x_t) \frac{\partial t}{\partial x_t} - t$$ $$0 \approx t + \frac{\partial \log f(x_t)}{\partial x_t} = (K'(t)-x_t) \frac{\partial t}{\partial x_t}$$ $t$$x_t$ $$K'(t) - x_t=0, \\ \tag{§} \label{§}$$

Điều chúng ta bỏ lỡ bây giờ khi xác định là và chúng ta có thể tìm thấy bằng cách phân biệt ngầm định phương trình yên ngựa : Kết quả là (tối đa xấp xỉ của chúng tôi) Đặt mọi thứ lại với nhau, chúng ta có xấp xỉ điểm yên cuối cùng của mật độ là h ″ ( t , x t ) = - ∂ 2 log f ( x t )$\eqref{*}$

$$h''(t,x_t) = -\frac{\partial^2 \log f(x_t)}{\partial x_t^2} \\ = -\frac{\partial}{\partial x_t} (\frac{\partial log f(x_t)}{\partial x_t} ) \\ = -\frac{\partial}{\partial x_t}(-t)= (\frac{\partial x_t}{\partial t})^{-1}$$ $K'(t)=x_t$ $$\frac{\partial x_t}{\partial t} = K''(t).$$ $$h''(t,x_t) = \frac1{K''(t)}$$ $f(x)$ $$f(x_t) \approx e^{K(t)- t x_t} \sqrt{\frac1{2\pi K''(t)}}.$$ Bây giờ, để sử dụng điều này một cách thực tế, để xấp xỉ mật độ tại một điểm cụ thể , chúng tôi giải phương trình yên ngựa cho đó để tìm .$x_t$$x_t$$t$

Giá trị gần đúng của điểm yên thường được xác định là xấp xỉ với mật độ trung bình dựa trên các quan sát iid . Hàm tạo tích lũy của giá trị trung bình chỉ đơn giản là , do đó, xấp xỉ điểm yên cho giá trị trung bình trở thành $n$$X_1, X_2, \dotsc, X_n$$n K(t)$

$$f(\bar{x}_t) = e^{nK(t) - n t \bar{x}_t} \sqrt{\frac{n}{2\pi K''(t)}}$$

Chúng ta hãy xem xét một ví dụ đầu tiên. Chúng ta sẽ nhận được gì nếu chúng ta cố gắng xấp xỉ mật độ chuẩn thông thường mgf là vì vậy nên phương trình yên ngựa là và phép tính xấp xỉ yên cho vì vậy trong trường hợp này, phép tính gần đúng là chính xác.

$$f(x)=\frac1{\sqrt{2\pi}} e^{-\frac12 x^2}$$ $M(t)=\exp(\frac12 t^2)$ $$K(t)=\frac12 t^2 \\ K'(t)=t \\ K''(t)=1$$ $t=x_t$ $$f(x_t) \approx e^{\frac12 t^2 -t x_t} \sqrt{\frac1{2\pi \cdot 1}} = \frac1{\sqrt{2\pi}} e^{-\frac12 x_t^2}$$

Chúng ta hãy xem xét một ứng dụng rất khác: Bootstrap trong miền biến đổi, chúng ta có thể thực hiện bootstrapping một cách phân tích bằng cách sử dụng xấp xỉ yên cho phân phối bootstrap của giá trị trung bình!

Giả sử chúng ta có iid được phân phối từ một số mật độ (trong ví dụ mô phỏng, chúng ta sẽ sử dụng phân phối theo cấp số nhân đơn vị). Từ mẫu, chúng tôi tính toán hàm tạo mô men theo kinh nghiệm và sau đó là cgf . Chúng ta cần mgf theo kinh nghiệm với nghĩa là và cgf theo kinh nghiệm cho trung bình mà chúng tôi sử dụng để xây dựng một xấp xỉ điểm yên ngựa. Trong một số mã R sau (phiên bản R 3.2.3): $X_1, X_2, \dotsc, X_n$$f$

$$\hat{M}(t)= \frac1{n} \sum_{i=1}^n e^{t x_i}$$ K (t)=log M (t)log( M (t/n$\hat{K}(t) = \log \hat{M}(t)$$\log ( \hat{M}(t/n)^n )$ $$\hat{K}_{\bar{X}}(t) = n \log \hat{M}(t/n)$$

set.seed(1234)
x  <-  rexp(10)

require(Deriv)   ### From CRAN
drule[["sexpmean"]]   <-  alist(t=sexpmean1(t))  # adding diff rules to 
                                                 # Deriv
drule[["sexpmean1"]]  <-  alist(t=sexpmean2(t))

###

make_ecgf_mean  <-   function(x)   {
    n  <-  length(x)
    sexpmean  <-  function(t) mean(exp(t*x))
    sexpmean1 <-  function(t) mean(x*exp(t*x))
    sexpmean2 <-  function(t) mean(x*x*exp(t*x))
    emgf  <-  function(t) sexpmean(t)
    ecgf  <-   function(t)  n * log( emgf(t/n) )
    ecgf1 <-   Deriv(ecgf)
    ecgf2 <-   Deriv(ecgf1)
    return( list(ecgf=Vectorize(ecgf),
                 ecgf1=Vectorize(ecgf1),
                 ecgf2 =Vectorize(ecgf2) )    )
}

### Now we need a function solving the saddlepoint equation and constructing
### the approximation:
###

make_spa <-  function(cumgenfun_list) {
    K  <- cumgenfun_list[[1]]
    K1 <- cumgenfun_list[[2]]
    K2 <- cumgenfun_list[[3]]
    # local function for solving the speq:
    solve_speq  <-  function(x) {
          # Returns saddle point!
          uniroot(function(s) K1(s)-x,lower=-100,
                  upper = 100, 
                  extendInt = "yes")$root
}
    # Function finding fhat for one specific x:
    fhat0  <- function(x) {
        # Solve saddlepoint equation:
        s  <-  solve_speq(x)
        # Calculating saddlepoint density value:
        (1/sqrt(2*pi*K2(s)))*exp(K(s)-s*x)
    }
    # Returning a vectorized version:
    return(Vectorize(fhat0))
} #end make_fhat

(Tôi đã cố viết mã này thành mã chung có thể dễ dàng sửa đổi cho các cgfs khác, nhưng mã vẫn không mạnh lắm ...)

Sau đó, chúng tôi sử dụng mẫu này cho một mẫu gồm mười quan sát độc lập từ phân bố hàm mũ đơn vị. Chúng tôi thực hiện "bẻ khóa" bằng tay thông thường, vẽ biểu đồ bootstrap kết quả cho giá trị trung bình và ghi đè lên xấp xỉ điểm yên ngựa:

> ECGF  <- make_ecgf_mean(x)
> fhat  <-  make_spa(ECGF)
> fhat
function (x) 
{
    args <- lapply(as.list(match.call())[-1L], eval, parent.frame())
    names <- if (is.null(names(args))) 
        character(length(args))
    else names(args)
    dovec <- names %in% vectorize.args
    do.call("mapply", c(FUN = FUN, args[dovec], MoreArgs = list(args[!dovec]), 
        SIMPLIFY = SIMPLIFY, USE.NAMES = USE.NAMES))
}
<environment: 0x4e5a598>
> boots  <-  replicate(10000, mean(sample(x, length(x), replace=TRUE)), simplify=TRUE)
> boots  <-  replicate(10000, mean(sample(x, length(x), replace=TRUE)), simplify=TRUE)
> hist(boots, prob=TRUE)
> plot(fhat, from=0.001, to=2, col="red", add=TRUE)

Đưa ra cốt truyện kết quả:

Sự gần đúng có vẻ là khá tốt!

Chúng ta có thể có được một xấp xỉ thậm chí tốt hơn bằng cách tích hợp xấp xỉ yên và thay đổi tỷ lệ:

> integrate(fhat, lower=0.1, upper=2)
1.026476 with absolute error < 9.7e-07

Bây giờ hàm phân phối tích lũy dựa trên phép tính gần đúng này có thể được tìm thấy bằng tích hợp số, nhưng cũng có thể thực hiện xấp xỉ điểm yên trực tiếp cho điều đó. Nhưng đó là cho một bài viết khác, điều này là đủ dài.

Cuối cùng, một số ý kiến ​​rời khỏi sự phát triển ở trên. Trong chúng tôi đã thực hiện một phép tính gần đúng về cơ bản bỏ qua thuật ngữ thứ ba. Tại sao chúng ta có thể làm điều đó? Một quan sát là đối với hàm mật độ bình thường, thuật ngữ bên trái không đóng góp gì, do đó, phép tính gần đúng là chính xác. Vì vậy, vì xấp xỉ yên ngựa là một sàng lọc trên định lý giới hạn trung tâm, vì vậy chúng tôi hơi gần với bình thường, vì vậy điều này sẽ hoạt động tốt. Người ta cũng có thể nhìn vào các ví dụ cụ thể. Nhìn vào xấp xỉ điểm yên ngựa với phân phối Poisson, nhìn vào thuật ngữ thứ ba còn sót lại, trong trường hợp này trở thành hàm trigamma, thực sự khá phẳng khi đối số không gần bằng không.$\eqref{**}$

Cuối cùng, tại sao tên? Tên đến từ một dẫn xuất thay thế, sử dụng các kỹ thuật phân tích phức tạp. Sau này chúng ta có thể xem xét điều đó, nhưng trong một bài viết khác!

Ở đây tôi mở rộng dựa trên câu trả lời của kjetil và tôi tập trung vào những tình huống mà Hàm tạo tích lũy (CGF) không xác định, nhưng có thể ước tính từ dữ liệu , trong đó . Công cụ ước tính CGF đơn giản nhất có lẽ là của Davison và Hinkley (1988) là cái được sử dụng trong ví dụ bootstrap của kjetil. Công cụ ước tính này có nhược điểm là phương trình yên ngựa kết quả có thể được giải nếu , điểm mà chúng tôi muốn đánh giá mật độ điểm yên, nằm trong thân lồi của . x ∈ R d K ( λ ) = $x_1,\dots,x_n$$x\in R^d$ K '(λ)=y,yx1,...,x

$$\hat{K}(\lambda) = \frac{1}{n}\sum_{i=1}^{n}e^{\lambda^Tx_i},$$ $$\hat{K}'(\lambda) = y,$$ $y$$x_1,\dots,x_n$

Wong (1992) và Fasiolo et al. (2016) đã giải quyết vấn đề này bằng cách đề xuất hai công cụ ước tính CGF thay thế, được thiết kế theo cách mà phương trình yên có thể được giải cho bất kỳ . Giải pháp của Fasiolo et al. (2016), được gọi là ESA xấp xỉ theo kinh nghiệm dựa trên kinh nghiệm mở rộng, được triển khai trong gói R yên ngựa và ở đây tôi đưa ra một vài ví dụ.$y$

Là một ví dụ đơn biến đơn giản, hãy xem xét sử dụng ESA để xấp xỉ mật độ .$\text{Gamma}(2, 1)$

library("devtools")
install_github("mfasiolo/esaddle")
library("esaddle")

########## Simulating data
x <- rgamma(1000, 2, 1)

# Fixing tuning parameter of ESA
decay <-  0.05

# Evaluating ESA at several point
xSeq <- seq(-2, 8, length.out = 200)
tmp <- dsaddle(y = xSeq, X = x, decay = decay, log = TRUE)

# Plotting true density, ESA and normal approximation
plot(xSeq, exp(tmp$llk), type = 'l', ylab = "Density", xlab = "x")
lines(xSeq, dgamma(xSeq, 2, 1), col = 3)
lines(xSeq, dnorm(xSeq, mean(x), sd(x)), col = 2)
suppressWarnings( rug(x) )
legend("topright", c("ESA", "Truth", "Gaussian"), col = c(1, 3, 2), lty = 1)

Đây là sự phù hợp

Nhìn vào tấm thảm, rõ ràng chúng tôi đã đánh giá mật độ ESA ngoài phạm vi dữ liệu. Một ví dụ khó khăn hơn là Gaussian bivariate bị biến dạng sau đây.

# Function that evaluates the true density
dwarp <- function(x, alpha) {
  d <- length(alpha) + 1
  lik <- dnorm(x[ , 1], log = TRUE)
  tmp <- x[ , 1]^2
  for(ii in 2:d)
    lik <- lik + dnorm(x[ , ii] - alpha[ii-1]*tmp, log = TRUE)
  lik
}

# Function that simulates from true distribution
rwarp <- function(n = 1, alpha) {
  d <- length(alpha) + 1
  z <- matrix(rnorm(n*d), n, d)
  tmp <- z[ , 1]^2
  for(ii in 2:d) z[ , ii] <- z[ , ii] + alpha[ii-1]*tmp
  z
}

set.seed(64141)
# Creating 2d grid
m <- 50
expansion <- 1
x1 <- seq(-2, 3, length=m)* expansion; 
x2 <- seq(-3, 3, length=m) * expansion
x <- expand.grid(x1, x2) 

# Evaluating true density on grid
alpha <- 1
dw <- dwarp(x, alpha = alpha)

# Simulate random variables
X <- rwarp(1000, alpha = alpha)

# Evaluating ESA density
dwa <- dsaddle(as.matrix(x), X, decay = 0.1, log = FALSE)$llk

# Plotting true density
par(mfrow = c(1, 2))
plot(X, pch=".", col=1, ylim = c(min(x2), max(x2)), xlim = c(min(x1), max(x1)),
     main = "True density", xlab = expression(X[1]), ylab = expression(X[2]))
contour(x1, x2, matrix(dw, m, m), levels = quantile(as.vector(dw), seq(0.8, 0.995, length.out = 10)), col=2, add=T)

# Plotting ESA density
plot(X, pch=".",col=2, ylim = c(min(x2), max(x2)), xlim = c(min(x1), max(x1)),
     main = "ESA density", xlab = expression(X[1]), ylab = expression(X[2]))
contour(x1, x2, matrix(dwa, m, m), levels = quantile(as.vector(dwa), seq(0.8, 0.995, length.out = 10)), col=2, add=T)

Phù hợp là khá tốt.

Nhờ câu trả lời tuyệt vời của Kjetil, tôi đang cố gắng tự mình đưa ra một ví dụ nhỏ, điều mà tôi muốn thảo luận bởi vì nó dường như nêu lên một điểm liên quan:

Hãy xem xét phân phối . và các dẫn xuất của nó có thể được tìm thấy ở đây và được sao chép trong các hàm trong mã dưới đây. K ( t $\chi^2(m)$$K(t)$

x <- seq(0.01,20,by=.1)
m <- 5

K  <- function(t,m) -1/2*m*log(1-2*t)
K1 <- function(t,m) m/(1-2*t)
K2 <- function(t,m) 2*m/(1-2*t)^2

saddlepointapproximation <- function(x) {
  t <- .5-m/(2*x)
  exp( K(t,m)-t*x )*sqrt( 1/(2*pi*K2(t,m)) )
}
plot( x, saddlepointapproximation(x), type="l", col="salmon", lwd=2)
lines(x, dchisq(x,df=m), col="lightgreen", lwd=2)

Điều này tạo ra

Điều này rõ ràng tạo ra một xấp xỉ có được các đặc tính định tính của mật độ, nhưng, như đã xác nhận trong nhận xét của Kjetil, không phải là mật độ thích hợp, vì nó nằm trên mật độ chính xác ở mọi nơi. Thay đổi kích thước gần đúng như sau sẽ đưa ra lỗi xấp xỉ không đáng kể được vẽ dưới đây.

scalingconstant <- integrate(saddlepointapproximation, x[1], x[length(x)])$value

approximationerror_unscaled <- dchisq(x,df=m) - saddlepointapproximation(x)
approximationerror_scaled   <- dchisq(x,df=m) - saddlepointapproximation(x) /
                                                    scalingconstant

plot( x, approximationerror_unscaled, type="l", col="salmon", lwd=2)
lines(x, approximationerror_scaled,             col="blue",   lwd=2)