tests/check-ME-estimates-monte-carlo.R

In geostan: Bayesian Spatial Analysis

##
## A Monte Carlo study to test measurement error models
##

library(geostan)

# flag for running Monte Carlo test or just code once
full_test <- FALSE

## no. iterations
M <- ifelse(full_test, 20, 1)

## a regular grid
ncol = 20
nrow = 20
sars <- prep_sar_data2(ncol, nrow, quiet = TRUE)
cars <- prep_car_data2(ncol, nrow, quiet = TRUE)
W <- sars$W
N <- nrow(W)

# iterate:
b = 0.5
g = -0.5
rho.x = 0 ## checking ME, not checking spatial models
rho.y = 0.6
sigma.y = 0.3
sigma.me = 0.3
pars <- c(const = 0,
          gamma = g,
          beta = b,
          rho = rho.y,
          scale = sigma.y)

res <- sapply(1:M, FUN = function(i) {

    x <- sim_sar(w=W, rho=rho.x)
    Wx <- (W %*% x)[,1]    
    mu <- b * x + g * Wx    
    y <- sim_sar(w=W, rho=rho.y, mu = mu, sigma = sigma.y, type = "SEM")
    x = x + rnorm(N, sd = sigma.me)        
    dat <- data.frame(y, x)    

    ME <- prep_me_data(se = data.frame(x = rep(sigma.me, N)))
    if (rho.x > 0) ME <- prep_me_data(se = data.frame(x = rep(sigma.me, N)), car_parts = cars)

    fit_sem_me <- geostan::stan_sar(y ~ x,
                                 data = dat,
                                 type = "SDEM",
                                 sar_parts = sars,
                                 ME = ME,
                                 chains = 1,
                                 iter = 600,
                                 quiet = TRUE,
                                 slim = TRUE
                                 ) |>
        suppressWarnings()

    fit_sem <- geostan::stan_sar(y ~ x,
                                  data = dat,
                                  type = "SDEM",
                                  sar_parts = sars,
                                  ## ME = ME, ##
                                  chains = 1,
                                  iter = 600,
                                  quiet = TRUE,
                                  slim = TRUE
                                  ) |>
        suppressWarnings()
    ## fit_glm0 <- geostan::stan_glm(y ~ x,
        ##                          slx = ~ x,
        ##                          data = dat,
        ##                          ## ME = ME, ##
        ##                          C = cars$C,
        ##                          chains = 1,
        ##                          iter = 600,
        ##                          quiet = TRUE,
        ##                          slim = TRUE
        ##                          ) |>
        ## suppressWarnings()
    ## fit_car <- geostan::stan_car(y ~ x,
    ##                              slx = ~ x,
    ##                              data = dat,
    ##                              car_parts = cars,
    ##                              ME = ME,
    ##                              chains = 1,
    ##                              iter = 900,
    ##                              quiet = TRUE,
    ##                              slim = TRUE
    ##                              ) |>
    ##     suppressWarnings()

    ## fit_glm <- geostan::stan_glm(y ~ x,
    ##                              slx = ~ x,
    ##                              data = dat,
    ##                              ME = ME,
    ##                              C = cars$C,
    ##                              chains = 1,
    ##                              iter = 900,
    ##                              quiet = TRUE,
    ##                              slim = TRUE
    ##                              ) |>
    ##     suppressWarnings()
    
    x <- c(
        # GLM0 = fit_glm0$summary[c('intercept', 'w.x', 'x', 'rho', 'sigma'), 'mean'],
       # GLM = fit_glm$summary[c('intercept', 'w.x', 'x', 'rho', 'sigma'), 'mean'],        
        SEM_ME = fit_sem_me$summary[c('intercept', 'w.x', 'x', 'sar_rho', 'sar_scale'), 'mean'],
        SEM = fit_sem$summary[c('intercept', 'w.x', 'x', 'sar_rho', 'sar_scale'), 'mean'] #,        
       # CAR = fit_car$summary[c('intercept', 'w.x', 'x', 'car_rho', 'car_scale'), 'mean']
        )
    
    return (x)
    
    })


RMSE <- function(est, true) sqrt(mean(est - true)^2)

g_res <- res |>
    subset(row.names(res) %in% c('SEM_ME2', 'SEM2'))
   ## subset(row.names(res) %in% c('GLM02', 'GLM2', 'SEM2', 'CAR2'))
b_res <- res |>
    subset(row.names(res) %in% c('SEM_ME3', 'SEM3'))    
     ##  subset(row.names(res) %in% c('GLM03', 'GLM2', 'SEM3', 'CAR3'))

cat("\n**\nRMSE of ME models: \n**\n")

cat("\n**\nGamma\n**\n")
apply(g_res, 1, RMSE, g) |>
    print(digits = 2)

cat("\n**\nBeta\n**\n")
apply(b_res, 1, RMSE, b) |>
    print(digits = 2)


cat("\n**\nME models\nSEM Estimates (rounded) should be close to DGP parameters \n",M, "iterations\n**\n")

est <- apply(res, 1, mean) 

est <- est[c('SEM2', 'SEM3', 'SEM_ME2', 'SEM_ME3')]

out <- data.frame(
   # Mod = attributes(est)$names,
    Par = rep(c('Gamma', 'Beta'), 2),
    DGP = c(g, b, g, b),
    Est = est
) |>
    transform(
        Error = round(Est - DGP, 2)
    ) 

out |>
    print()

write.csv(out, "check-ME-estimates-monte-carlo-output.csv")