
R version 3.6.3 (2020-02-29) -- "Holding the Windsock"
Copyright (C) 2020 The R Foundation for Statistical Computing
Platform: x86_64-pc-linux-gnu (64-bit)

R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
Type 'license()' or 'licence()' for distribution details.

R is a collaborative project with many contributors.
Type 'contributors()' for more information and
'citation()' on how to cite R or R packages in publications.

Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R.

> 
>  epsilon <- 1e-15
> 
>  library(mcmc)
> 
>  RNGkind("Marsaglia-Multicarry")
>  set.seed(42)
> 
>  options(digits = 3)
> 
>  n <- 100
>  rho <- 0.5
>  beta0 <- 0.25
>  beta1 <- 1
>  beta2 <- 0.5
> 
>  x1 <- rnorm(n)
>  x2 <- rho * x1 + sqrt(1 - rho^2) * rnorm(n)
>  eta <- beta0 + beta1 * x1 + beta2 * x2
>  p <- 1 / (1 + exp(- eta))
>  y <- as.numeric(runif(n) < p)
> 
>  out <- glm(y ~ x1 + x2, family = binomial())
>  summary(out)

Call:
glm(formula = y ~ x1 + x2, family = binomial())

Deviance Residuals: 
   Min      1Q  Median      3Q     Max  
-2.064  -0.821  -0.246   0.840   2.070  

Coefficients:
            Estimate Std. Error z value Pr(>|z|)    
(Intercept)   0.0599     0.2477    0.24  0.80905    
x1            1.3682     0.3844    3.56  0.00037 ***
x2            0.4760     0.3135    1.52  0.12886    
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

(Dispersion parameter for binomial family taken to be 1)

    Null deviance: 138.469  on 99  degrees of freedom
Residual deviance:  99.293  on 97  degrees of freedom
AIC: 105.3

Number of Fisher Scoring iterations: 5

> 
>  mlogl <- function(beta) {
+      if (length(beta) != 3) stop("length(beta) != 3")
+      beta0 <- beta[1]
+      beta1 <- beta[2]
+      beta2 <- beta[3]
+      eta <- beta0 + beta1 * x1 + beta2 * x2
+      p <- exp(eta) / (1 + exp(eta))
+      return(- sum(log(p[y == 1])) - sum(log(1 - p[y == 0])))
+  }
> 
> ## IGNORE_RDIFF_BEGIN
>  out.nlm <- nlm(mlogl, coefficients(out), print.level = 2)
iteration = 0
Parameter:
[1] 0.0599 1.3682 0.4760
Function Value
[1] 49.6
Gradient:
[1] 8.24e-06 5.50e-06 6.08e-06

Relative gradient close to zero.
Current iterate is probably solution.

> ## IGNORE_RDIFF_END
> 
>  logl <- function(beta) {
+      if (length(beta) != 3) stop("length(beta) != 3")
+      beta0 <- beta[1]
+      beta1 <- beta[2]
+      beta2 <- beta[3]
+      eta <- beta0 + beta1 * x1 + beta2 * x2
+      p <- exp(eta) / (1 + exp(eta))
+      return(sum(log(p[y == 1])) + sum(log(1 - p[y == 0])))
+  }
> 
>  out.metro <- metrop(logl, coefficients(out), 1e3, scale = 0.01)
>  out.metro$accept
[1] 0.982
> 
>  out.metro <- metrop(out.metro, scale = 0.1)
>  out.metro$accept
[1] 0.795
> 
>  out.metro <- metrop(out.metro, scale = 0.5)
>  out.metro$accept
[1] 0.264
> 
>  apply(out.metro$batch, 2, mean)
[1] 0.0608 1.4230 0.5263
>  var(out.metro$batch)
         [,1]    [,2]     [,3]
[1,]  0.06755 -0.0108  0.00989
[2,] -0.01080  0.1758 -0.06155
[3,]  0.00989 -0.0615  0.10483
>  olbm(out.metro$batch, 25)
          [,1]      [,2]      [,3]
[1,]  4.54e-04  9.47e-05 -1.92e-05
[2,]  9.47e-05  1.84e-03 -6.45e-04
[3,] -1.92e-05 -6.45e-04  9.09e-04
> 
>  saveseed <- .Random.seed
>  out.metro <- metrop(logl, as.numeric(coefficients(out)), 1e2,
+      scale = 0.5, debug = TRUE)
> 
>  all(out.metro$batch[- out.metro$nbatch, ] == out.metro$current[- 1, ])
[1] TRUE
>  all(out.metro$current[1, ] == out.metro$initial)
[1] TRUE
>  all(out.metro$batch[out.metro$nbatch, ] == out.metro$final)
[1] TRUE
> 
>  .Random.seed <- saveseed
>  d <- ncol(out.metro$proposal)
>  n <- nrow(out.metro$proposal)
>  my.proposal <- matrix(NA, n, d)
>  my.u <- double(n)
>  ska <- out.metro$scale
>  for (i in 1:n) {
+      my.proposal[i, ] <- out.metro$current[i, ] + ska * rnorm(d)
+      if (is.na(out.metro$u[i])) {
+          my.u[i] <- NA
+      } else {
+          my.u[i] <- runif(1)
+      }
+  }
>  max(abs(out.metro$proposal - my.proposal)) < epsilon
[1] TRUE
>  all(is.na(out.metro$u) == is.na(my.u))
[1] TRUE
>  all(out.metro$u[!is.na(out.metro$u)] == my.u[!is.na(my.u)])
[1] TRUE
> 
>  my.curr.log.green <- apply(out.metro$current, 1, logl)
>  my.prop.log.green <- apply(out.metro$proposal, 1, logl)
>  all(is.na(out.metro$u) == (my.prop.log.green > my.curr.log.green))
[1] TRUE
>  foo <- my.prop.log.green - my.curr.log.green
>  max(abs(foo - out.metro$log.green)) < epsilon
[1] TRUE
> 
>  my.accept <- is.na(my.u) | my.u < exp(foo)
>  sum(my.accept) == round(n * out.metro$accept)
[1] TRUE
> 
>  my.path <- matrix(NA, n, d)
>  my.path[my.accept, ] <- out.metro$proposal[my.accept, ]
>  my.path[! my.accept, ] <- out.metro$current[! my.accept, ]
> 
>  all(my.path == out.metro$batch)
[1] TRUE
> 
> 
> proc.time()
   user  system elapsed 
  0.326   0.027   0.343 
