使用自适应拒绝抽样方法（R）

Question

我对R不太熟悉。我一直在尝试在R中使用adaptive rejection sampling方法的实现，以便从以下分布中进行抽样：

这是我的R代码：

library(ars)
g1 <- function(x,r){(1./r)*((1-x)^r)}
f1 <- function(x,a,k) {
  add<-0
  for(i in 1:k) {
  add<- add+g1(x,i)
  }
  res <- (a* add)+(a-1)*log(x)+k*log(1-x)
  return(res)
}

g2 <- function(x,r){(1-x)^(r-1)}  
f1prima <- function(x,a,k) {
  add<-0
  for(i in 1:k) {
  add<- add-g2(x,i)
  }
  res <- (a* add)+(a-1)/x-k/(1-x)
  return(res)
}
mysample1<-ars(20,f1,f1prima,x=c(0.001,0.09),m=2,emax=128,lb=TRUE,xlb=0.0, ub=TRUE, xub=1,a=0.5,k=100)

该功能是一个 log-concave ，但是当我运行 ars 时，我会收到不同的错误消息，并且输入参数在这里不知所措。任何建议都将不胜感激。

Answer 1

首先，你已经注意到你的对数凹函数在x = 0和x = 1.0时没有很好地定义。如此有用的区间将是0.01 ... 0.99，而不是0.0 ... 1.0

其次，我不喜欢在你的求和项中计算数百个术语的想法。 所以，好主意可能是以下面的方式表达它，从衍生

开始

S ₁ ^N-1 q ⁱ 显然是geometric series，可以替换为 （1-q ^N ）/（1-q），其中q = 1-x。

这是衍生的，所以要在功能本身中找到相似的术语，只需将其集成即可。

http://www.wolframalpha.com/input/?i=integrate+(1-q%5EN)%2F(1-q)+dq将返回Gauss Hypergeometric function ₂F₁加上logarithm

-q ^{N + 1} ₂ F ₁ （1，N + 1; N + 2; q）/（N + 1 ） - log（1-q）

注意：它与Beta之前的积分相同，但处理它有点麻烦 所以，计算这些术语的代码：

library(gsl)
library(ars)
library(ggplot2)

Gauss2F1 <- function(a, b, c, x) {
    ifelse(x >= 0.0 & x < 1.0, hyperg_2F1(a, b, c, x), hyperg_2F1(c - a, b, c, 1.0 - 1.0/(1.0 - x))/(1.0 - x)^b)
}

f1sum <- function(x, N) {
    q <- 1.0 - x
    - q^(N+1) * Gauss2F1(1, N+1, N+2, q)/(N+1) - log(1.0 - q) 
}

f1sum.1 <- function(x, N) {
    q <- 1.0 - x
    res <- rep(0.0, length.out = length(x))
    s <- rep(1.0, length.out = length(x))
    for(k in 1:N) {
        s <- s * q / as.numeric(k)
        res <- res + s
    }
    res
}

f1 <- function(x, a, N) {
    a * f1sum(x, N) + (a - 1.0)*log(x) + N*log(1.0 - x)
}

f1.1 <- function(x, a, N) {
    a * f1sum.1(x, N) + (a - 1.0)*log(x) + N*log(1.0 - x)
}

f1primesum <- function(x, N) {
    q <- 1.0 - x
    (1.0 - q^N)/(1.0 - q)
}

f1primesum.1 <- function(x, N) {
    res <- rep(0.0, length.out = length(x))
    s <- rep(1.0, length.out = length(x))
    for(k in 1:N) {
        res <- res + s
        s <- s * q
    }
    -res
}

f1prime <- function(x, a, N) {
    a* f1primesum(x, N) + (a - 1.0)/x - N/(1.0 - x)
}

f1prime.1 <- function(x, a, N) {
    a* f1primesum.1(x, N) + (a - 1.0)/x - N/(1.0 - x)
}

p <- ggplot(data.frame(x = c(0, 1)), aes(x = x)) +
    stat_function(fun = f1, args = list(0.5, 100), colour = "#4271AE") +
    stat_function(fun = f1.1, args = list(0.5, 100), colour = "#1F3552") +
    scale_x_continuous(name = "X", breaks = seq(0, 1, 0.2), limits=c(0.001, 0.5)) +
    scale_y_continuous(name = "F") +
    ggtitle("Log-concave function")
p

正如你所看到的，我已经实现了两个版本 - 一个使用求和，另一个使用求和的分析形式。计算数据为a = 0.5，N = 100。

首先，直接和和2F1之间有一点区别 - 我把它归结为求和中的精度损失。

其次，更重要的结果 - 功能不是对数凹。如果ars()左右失败，请不要怀疑。见下图