Hasilkan titik secara efisien antara satuan lingkaran dan satuan bujur sangkar

Saya ingin menghasilkan sampel dari wilayah biru yang didefinisikan di sini:

Solusi naif adalah menggunakan sampel penolakan di unit square, tetapi ini hanya memberikan efisiensi (~ 21,4%).$1-\pi/4$

Apakah ada cara agar saya dapat mencicipi lebih efisien?

Apakah dua juta poin per detik akan berhasil?

Distribusinya simetris: kita hanya perlu mengerjakan distribusi untuk seperdelapan dari lingkaran penuh dan kemudian menyalinnya di sekitar oktan lainnya. Dalam koordinat kutub , distribusi kumulatif sudut Θ untuk lokasi acak ( X , Y ) pada nilai θ diberikan oleh area antara segitiga ( 0 , 0 ) , ( 1 , 0 ) , ( 1 , tan θ ) dan lengkungan lingkaran memanjang dari $(r,\theta)$$\Theta$$(X,Y)$$\theta$$(0,0), (1,0), (1,\tan\theta)$ hingga ( cos θ , sin θ ) . Dengan demikian sebanding dengan$(1,0)$$(\cos\theta,\sin\theta)$

$$F_\Theta(\theta) = \Pr(\Theta \le \theta) \propto \frac{1}{2}\tan(\theta) - \frac{\theta}{2},$$

dari mana kepadatannya

$$f_\Theta(\theta) = \frac{d}{d\theta} F_\Theta(\theta) \propto \tan^2(\theta).$$

Kami dapat mengambil sampel dari kerapatan ini menggunakan, katakanlah, metode penolakan (yang memiliki efisiensi ).$8/\pi-2 \approx 54.6479\%$

Densitas kondisional dari koordinat radial sebanding dengan r d r antara r = 1 dan r = sec θ . Itu dapat disampel dengan inversi CDF yang mudah.$R$$rdr$$r=1$$r=\sec\theta$

Jika kita menghasilkan sampel independen , konversi kembali ke koordinat Cartesian ( x i , y i ) sampel oktan ini. Karena sampel independen, swapping koordinat secara acak menghasilkan sampel acak independen dari kuadran pertama, seperti yang diinginkan. (Swap acak memerlukan hanya menghasilkan variabel Binomial tunggal untuk menentukan berapa banyak realisasi untuk bertukar.)$(r_i,\theta_i)$$(x_i,y_i)$

Setiap realisasi membutuhkan rata-rata satu varian seragam (untuk R ) ditambah 1 / ( 8 π - 2 ) kali dua varian seragam (untuk Θ ) dan sejumlah kecil perhitungan (cepat). Itu 4 / ( π - 4 ) ≈ 4,66 variasi per titik (yang, tentu saja, memiliki dua koordinat). Rincian lengkap ada pada contoh kode di bawah ini. Angka ini memplot 10.000 dari lebih dari setengah juta poin yang dihasilkan.$(X,Y)$$R$$1/(8\pi-2)$$\Theta$$4/(\pi-4) \approx 4.66$

Berikut adalah Rkode yang menghasilkan simulasi ini dan menghitung waktunya.

n.sim <- 1e6
x.time <- system.time({
  # Generate trial angles `theta`
  theta <- sqrt(runif(n.sim)) * pi/4
  # Rejection step.
  theta <- theta[runif(n.sim) * 4 * theta <= pi * tan(theta)^2]
  # Generate radial coordinates `r`.
  n <- length(theta)
  r <- sqrt(1 + runif(n) * tan(theta)^2)
  # Convert to Cartesian coordinates.
  # (The products will generate a full circle)
  x <- r * cos(theta) #* c(1,1,-1,-1)
  y <- r * sin(theta) #* c(1,-1,1,-1)
  # Swap approximately half the coordinates.
  k <- rbinom(1, n, 1/2)
  if (k > 0) {
    z <- y[1:k]
    y[1:k] <- x[1:k]
    x[1:k] <- z
  }
})
message(signif(x.time[3] * 1e6/n, 2), " seconds per million points.")
#
# Plot the result to confirm.
#
plot(c(0,1), c(0,1), type="n", bty="n", asp=1, xlab="x", ylab="y")
rect(-1, -1, 1, 1, col="White", border="#00000040")
m <- sample.int(n, min(n, 1e4))
points(x[m],y[m], pch=19, cex=1/2, col="#0000e010")

Saya mengusulkan solusi berikut, yang seharusnya lebih sederhana, lebih efisien dan / atau lebih murah secara komputasi daripada sesi lainnya oleh @ cardinal, @whuber dan @ stephan-kolassa sejauh ini.

Ini melibatkan langkah-langkah sederhana berikut:

$$u_1 \sim Unif(0,1)\\ u_2 \sim Unif(0,1).$$

$\min\{u_1,u_2\}, \max\{u_1,u_2\}$

$$\begin{bmatrix} x\\y \end{bmatrix} = \begin{bmatrix} 1\\1 \end{bmatrix} + \begin{bmatrix} \frac{\sqrt{2}}{2} & -1\\ \frac{\sqrt{2}}{2} - 1 & 0\\ \end{bmatrix} \, \begin{bmatrix} \min\{u_1,u_2\}\\ \max\{u_1,u_2\}\\ \end{bmatrix}.$$

$x$$y$$u_1 > u_2$

$$x^2 + y^2 < 1.$$

Intuisi di balik algoritma ini ditunjukkan pada gambar.

Langkah 2a dan 2b dapat digabungkan menjadi satu langkah:

$$x = 1 + \frac{\sqrt{2}}{2} \min(u_1, u_2) - u_2\\ y = 1 + \frac{\sqrt{2}}{2} \min(u_1, u_2) - u_1$$

Kode berikut mengimplementasikan algoritma di atas (dan mengujinya menggunakan kode @ whuber).

n.sim <- 1e6
x.time <- system.time({
    # Draw two standard uniform samples
    u_1 <- runif(n.sim)
    u_2 <- runif(n.sim)
    # Apply shear transformation and swap
    tmp <- 1 + sqrt(2)/2 * pmin(u_1, u_2)
    x <- tmp - u_2
    y <- tmp - u_1
    # Reject if inside circle
    accept <- x^2 + y^2 > 1
    x <- x[accept]
    y <- y[accept]
    n <- length(x)
})
message(signif(x.time[3] * 1e6/n, 2), " seconds per million points.")
#
# Plot the result to confirm.
#
plot(c(0,1), c(0,1), type="n", bty="n", asp=1, xlab="x", ylab="y")
rect(-1, -1, 1, 1, col="White", border="#00000040")
m <- sample.int(n, min(n, 1e4))
points(x[m],y[m], pch=19, cex=1/2, col="#0000e010")

Beberapa tes cepat menghasilkan hasil berikut.

Algoritma /stats//a/258349 . Terbaik 3: 0,33 detik per juta poin.

Algoritma ini. Terbaik 3: 0,18 detik per juta poin.

Ya, lebih efisien bisa dilakukan, tapi saya harap Anda tidak mencari lebih cepat .

$x$$x$

$$f(x) = 1-\sqrt{1-x^2}.$$

Wolfram membantu Anda untuk mengintegrasikan itu :

$$\int_0^x f(y)dy = -\frac{1}{2}x\sqrt{1-x^2}+x-\frac{1}{2}\arcsin x.$$

So the cumulative distribution function $F$ would be this expression, scaled to integrate to 1 (i.e., divided by $\int_0^1 f(y)dy$).

Now, to generate your $x$ value, pick a random number $t$, uniformly distributed between $0$ and $1$. Then find $x$ such that $F(x)=t$. That is, we need to invert the CDF (inverse transform sampling). This can be done, but it's not easy. Nor fast.

Finally, given $x$, pick a random $y$ that is uniformly distributed between $\sqrt{1-x^2}$ dan $1$.

Di bawah ini adalah kode R. Perhatikan bahwa saya sedang mengevaluasi CDF di kisi$x$ nilai-nilai, dan itupun dibutuhkan beberapa menit.

Anda mungkin dapat mempercepat inversi CDF sedikit jika Anda berinvestasi beberapa pemikiran. Kemudian lagi, berpikir itu menyakitkan. Saya pribadi akan mengambil sampel penolakan, yang lebih cepat dan jauh lebih sedikit kesalahan, kecuali saya punya alasan yang sangat bagus untuk tidak melakukannya.

epsilon <- 1e-6
xx <- seq(0,1,by=epsilon)
x.cdf <- function(x) x-(x*sqrt(1-x^2)+asin(x))/2
xx.cdf <- x.cdf(xx)/x.cdf(1)

nn <- 1e4
rr <- matrix(nrow=nn,ncol=2)
set.seed(1)
pb <- winProgressBar(max=nn)
for ( ii in 1:nn ) {
    setWinProgressBar(pb,ii,paste(ii,"of",nn))
    x <- max(xx[xx.cdf<runif(1)])
    y <- runif(1,sqrt(1-x^2),1)
    rr[ii,] <- c(x,y)
}
close(pb)

plot(rr,pch=19,cex=.3,xlab="",ylab="")