การประมาณ saddlepoint ทำงานอย่างไร

วิธีไม่ทำงานประมาณ saddlepoint? ปัญหาแบบไหนที่ดีสำหรับ
(อย่าลังเลที่จะใช้ตัวอย่างหรือตัวอย่างเฉพาะตามภาพประกอบ)

มีข้อบกพร่องความยากลำบากสิ่งต่าง ๆ ที่ต้องระวังหรือกับดักสำหรับคนไม่ระมัดระวังหรือไม่?

การประมาณค่า saddlepoint กับฟังก์ชันความหนาแน่นของความน่าจะเป็น (มันทำงานเหมือนกันสำหรับฟังก์ชั่นมวล แต่ฉันจะพูดที่นี่ในแง่ของความหนาแน่นเท่านั้น) เป็นการประมาณที่ทำงานได้ดีอย่างน่าประหลาดใจซึ่งสามารถมองเห็นได้ว่าเป็นการปรับแต่ง ดังนั้นมันจะทำงานเฉพาะในการตั้งค่าที่มีทฤษฎีบทขีด จำกัด กลาง แต่มันต้องมีสมมติฐานที่แข็งแกร่ง

เราเริ่มต้นด้วยการสันนิษฐานว่าฟังก์ชั่นการสร้างช่วงเวลานั้นมีอยู่และสามารถเปลี่ยนแปลงได้สองครั้ง นี่หมายถึงโดยเฉพาะอย่างยิ่งว่าทุกช่วงเวลามีอยู่ ให้เป็นตัวแปรสุ่มที่มีฟังก์ชั่นสร้างช่วงเวลา (mgf) และ cgf (ฟังก์ชันสร้างลบ) (โดยที่หมายถึงลอการิทึมธรรมชาติ) ในการพัฒนาฉันจะติดตาม Ronald W Butler อย่างใกล้ชิด: "การประมาณ Saddlepoint ด้วยแอปพลิเคชัน" (CUP) เราจะพัฒนาการประมาณ saddlepoint โดยใช้การประมาณ Laplace เป็นอินทิกรัลที่แน่นอน เขียน $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$$ ที่ (x) ตอนนี้เราจะขยายเทย์เลอร์ในพิจารณาเป็นค่าคงที่ นี่จะให้ โดยที่'หมายถึงความแตกต่างด้วยความเคารพx โปรดทราบว่า h '(t, x) = - t- \ frac {\ partial} {\ partial x} \ log f (x) \\ h' '(t, x) = - \ frac {\ partial ^ 2} {\ partial x ^ 2} \ log f (x)> 0 (ความไม่เท่าเทียมกันครั้งล่าสุดโดยสมมติว่ามันเป็นสิ่งจำเป็นสำหรับการประมาณการทำงาน) ให้x_t$h(t,x) = -tx - \log f(x)$$h(t,x)$$x$$t$ $$h(t,x)=h(t,x_0) + h'(t,x_0)(x-x_0) +\frac12 h''(t,x_0) (x-x_0)^2 +\dotsm$$ $'$$x$ $$h'(t,x)=-t-\frac{\partial}{\partial x}\log f(x) \\ h''(t,x)= -\frac{\partial^2}{\partial x^2} \log f(x) > 0$$ $x_t$เป็นวิธีการแก้$h'(t,x_t)=0$ 0 เราจะคิดว่านี้จะช่วยให้ขั้นต่ำสำหรับ $h(t,x)$เป็นฟังก์ชันของx$x$การใช้ส่วนขยายนี้ในอินทิกรัลและลืมเกี่ยวกับส่วน$\dotsm$ให้ $$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$$ about \ 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 ซึ่งเป็นส่วนประกอบของเกาส์ให้ $$e^{K(t)} \approx e^{-h(t,x_t)} \sqrt{\frac{2\pi}{h''(t,x_t)}}.$$ เรื่องนี้ทำให้ (ประมาณรุ่นแรก) ของ saddlepoint ประมาณ $$f(x_t) \approx \sqrt{\frac{h''(t,x_t)}{2\pi}} \exp(K(t) -t x_t) \\ \tag{*} \label{*}$$ โปรดทราบว่าการประมาณนั้นมีรูปแบบของตระกูลเอ็กซ์โพเนนเชียล

ตอนนี้เราต้องทำงานบางอย่างเพื่อให้ได้สิ่งนี้ในรูปแบบที่มีประโยชน์มากขึ้น

จากเราได้รับ การแยกแยะสิ่งนี้เทียบกับให้ (โดยสมมติฐานของเรา), ดังนั้นความสัมพันธ์ระหว่างและจึงเป็นแบบโมโนโทนดังนั้นจึงถูกกำหนดไว้อย่างดี เราจำเป็นต้องมีการประมาณที่จะ(x_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)$$\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{**}$$ สมมติว่าคำสุดท้ายข้างต้นขึ้นอยู่กับเพียงเล็กน้อยดังนั้นอนุพันธ์ของมันที่เกี่ยวกับอยู่ที่ประมาณศูนย์ (เราจะกลับมาแสดงความคิดเห็นในเรื่องนี้) เราจะได้รับ ขึ้นอยู่กับการประมาณนี้เราจึงได้ ดังนั้นและต้องสัมพันธ์กันผ่านสมการ ซึ่งเรียกว่าสมการอานม้า $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{§}$$

สิ่งที่เราพลาดตอนนี้ในการกำหนดคือ และเราสามารถค้นหาโดยนัยของความแตกต่างของสมการ Saddlepoint : ผลก็คือ (ขึ้นอยู่กับการประมาณของเรา) ใส่ทุกอย่างเข้าด้วยกันเรามี saddlepoint สุดท้ายของความหนาแน่นเป็น $\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)}}.$$ ตอนนี้จะใช้ในทางปฏิบัติที่ใกล้เคียงกับความหนาแน่นที่จุดที่เฉพาะเจาะจงเราแก้สม saddlepoint สำหรับที่เพื่อหาเสื้อ$x_t$$x_t$$t$

ประมาณ saddlepoint มักจะระบุไว้เป็นประมาณความหนาแน่นของค่าเฉลี่ยอยู่บนพื้นฐานของสังเกต IIDX_n ฟังก์ชันการสร้าง Cumulant ของค่าเฉลี่ยคือดังนั้นการประมาณค่าของอานม้าจึงกลายเป็น $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)}}$$

ให้เราดูตัวอย่างแรก เราจะได้อะไรถ้าเราพยายามประมาณความหนาแน่นปกติมาตรฐาน mgf คือดังนั้น ดังนั้นสมการ saddlepoint คือและการประมาณ saddlepoint ทำให้ ดังนั้นในกรณีนี้การประมาณนั้นแน่นอน

$$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}$$

ให้เราดูแอปพลิเคชันที่แตกต่างกันมาก: Bootstrap ในโดเมนการแปลงเราสามารถทำการ bootstrapping เชิงวิเคราะห์โดยใช้การประมาณ saddlepoint เพื่อการกระจาย bootstrap ของค่าเฉลี่ย!

สมมติว่าเรามี iid จากความหนาแน่น (ในตัวอย่างที่จำลองเราจะใช้การแจกแจงเลขชี้กำลังของหน่วย) จากตัวอย่างเราคำนวณฟังก์ชันสร้างช่วงเวลาเชิงประจักษ์ และจากนั้น cgf(t) เราต้องการประจักษ์ mgf สำหรับค่าเฉลี่ยซึ่งและ cgf เชิงประจักษ์สำหรับค่าเฉลี่ย ซึ่งเราใช้ในการสร้างการประมาณ saddlepoint ในรหัส R ต่อไปนี้ (รุ่น 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}$$ $\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

(ฉันพยายามเขียนเป็นรหัสทั่วไปซึ่งสามารถแก้ไขได้อย่างง่ายดายสำหรับ cgfs อื่น ๆ แต่รหัสยังไม่แข็งแกร่งมาก ... )

จากนั้นเราใช้สิ่งนี้สำหรับตัวอย่างของการสังเกตอิสระสิบครั้งจากการแจกแจงแบบเลขชี้กำลังของหน่วย เราทำ bootstrapping nonparametric ปกติ "ด้วยมือ" พล็อตกราฟแท่ง bootstrap ผลลัพธ์สำหรับค่าเฉลี่ยและ overplot ประมาณ saddlepoint:

> 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)

การให้พล็อตผลลัพธ์:

การประมาณนั้นค่อนข้างดี!

เราจะได้การประมาณที่ดียิ่งขึ้นโดยการรวมการประมาณค่าของอานและการลดขนาด:

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

ตอนนี้ฟังก์ชั่นการแจกแจงสะสมตามการประมาณนี้สามารถพบได้โดยการรวมเชิงตัวเลข แต่ก็เป็นไปได้ที่จะทำการประมาณ saddlepoint โดยตรงสำหรับสิ่งนั้น แต่นั่นเป็นอีกโพสต์นี้นานพอ

ในที่สุดความคิดเห็นบางส่วนออกจากการพัฒนาข้างต้น ในเราทำการประมาณค่าโดยไม่สนใจเทอมที่สาม ทำไมเราทำอย่างนั้นได้? สิ่งหนึ่งที่สังเกตได้คือสำหรับฟังก์ชันความหนาแน่นปกติเทอมซ้ายไม่มีส่วนอะไรเลยดังนั้นการประมาณนั้นแน่นอน ดังนั้นเนื่องจากการประมาณค่าแบบอานม้าเป็นการปรับแต่งในทฤษฎีบทขีด จำกัด กลางดังนั้นเราจึงค่อนข้างใกล้เคียงกับปกติดังนั้นสิ่งนี้ควรทำงานได้ดี ท่านสามารถดูตัวอย่างเฉพาะได้ ดูการประมาณ saddlepoint กับการแจกแจงปัวซอง, ดูเทอมที่สามที่ยังเหลือ, ในกรณีนี้ที่กลายเป็นฟังก์ชันตรีมาม่า, ซึ่งแน่นอนว่าค่อนข้างแบนเมื่ออาร์กิวเมนต์ไม่ใกล้ศูนย์$\eqref{**}$

ในที่สุดทำไมชื่อ? ชื่อนี้มาจากทางเลือกอื่นโดยใช้เทคนิคการวิเคราะห์เชิงซ้อน หลังจากนั้นเราสามารถตรวจสอบได้ แต่ในโพสต์อื่น!

ที่นี่ผมขยายความคำตอบที่เคอร์วินและผมเน้นสถานการณ์เหล่านั้นที่ cumulant ผลิตฟังก์ชั่น (CGF) เป็นที่รู้จัก แต่ก็สามารถประมาณจากข้อมูลที่ d ตัวประมาณ CGF ที่ง่ายที่สุดน่าจะเป็นของDavison และ Hinkley (1988) ซึ่งเป็นสิ่งที่ใช้ในตัวอย่าง bootstrap ของ kjetil ตัวประมาณนี้มีข้อเสียเปรียบว่าผลลัพธ์ของสมการอานม้า สามารถแก้ไขได้ก็ต่อเมื่อซึ่งเป็นจุดที่เราต้องการประเมินความหนาแน่นของอานม้าที่อยู่ภายในเปลือกของ\$x_1,\dots,x_n$$x\in R^d$

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

วงศ์ (1992)และFasiolo และคณะ (2016)การแก้ไขปัญหานี้โดยการเสนอสองประมาณ CGF ทางเลือกที่ได้รับการออกแบบในลักษณะดังที่สม saddlepoint จะสามารถแก้ไขได้สำหรับการใด ๆYทางออกของ Fasiolo และคณะ (2016) เรียกว่า Empirical Saddlepoint ประมาณ ESA ถูกนำมาใช้ในแพ็คเกจ esaddle Rและที่นี่ฉันให้ตัวอย่าง$y$

ในฐานะที่เป็นตัวอย่างที่ไม่แปรเปลี่ยนง่ายลองใช้ ESA เพื่อประมาณความหนาแน่น$\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)

นี่คือความพอดี

เมื่อมองดูพรมเป็นที่ชัดเจนว่าเราประเมินความหนาแน่น ESA นอกช่วงข้อมูล ตัวอย่างที่ท้าทายมากขึ้นคือ Gaussian bivariate ที่บิดเบี้ยวต่อไปนี้

# 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)

พอดีค่อนข้างดี

ขอบคุณคำตอบที่ยอดเยี่ยมของ Kjetil ฉันพยายามหาตัวอย่างเล็ก ๆ น้อย ๆ ด้วยตัวเองซึ่งฉันอยากจะพูดคุยเพราะดูเหมือนว่าจะยกประเด็นที่เกี่ยวข้อง:

พิจารณาการจัดจำหน่าย และอนุพันธ์อาจพบได้ที่นี่และมีการทำซ้ำในฟังก์ชั่นในรหัสด้านล่าง $\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)

สิ่งนี้ผลิต

สิ่งนี้ทำให้เกิดการประมาณที่ได้รับคุณสมบัติเชิงคุณภาพของความหนาแน่นที่ถูกต้อง แต่ตามที่ได้รับการยืนยันในความคิดเห็นของ Kjetil นั้นไม่ใช่ความหนาแน่นที่เหมาะสมเนื่องจากอยู่เหนือความหนาแน่นที่แน่นอนทุกที่ การลดขนาดการประมาณดังต่อไปนี้จะทำให้เกิดข้อผิดพลาดโดยประมาณที่เกือบจะไม่ได้รับการพล็อตด้านล่าง

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)