inst/doc/od-migration.R

In cevcmm: Communication-Efficient Varying Coefficient Mixed-Effects Models

## ----include = FALSE----------------------------------------------------------
knitr::opts_chunk$set(
  collapse  = TRUE,
  comment   = "#>",
  fig.width = 6,
  fig.height = 4,
  fig.align = "center"
)
set.seed(24)

## ----setup--------------------------------------------------------------------
library(cevcmm)

## ----load---------------------------------------------------------------------
path <- system.file("extdata", "od_migration.csv", package = "cevcmm")
od   <- read.csv(path)
str(od)
head(od)

## ----build-z------------------------------------------------------------------
G <- 10L
N <- nrow(od)

Z <- matrix(0, N, 2L * G)
Z[cbind(seq_len(N), od$origin)]    <- 1   # origin indicators in cols 1..G
Z[cbind(seq_len(N), G + od$dest)]  <- 1   # destination indicators in cols (G+1)..2G

# Verify the OD structure: every row sums to 2 (one origin + one dest)
table(rowSums(Z))

## ----sigma-spatial------------------------------------------------------------
Sigma_spatial <- outer(seq_len(G), seq_len(G),
                       function(i, j) exp(-abs(i - j) / 3))
round(Sigma_spatial[1:4, 1:4], 3)

## ----fit----------------------------------------------------------------------
fit <- vcmm(y = od$log_flow,
            X = od$wage_diff,
            Z = Z,
            t = od$t,
            method             = "csl",
            re_cov             = "kronecker",
            n_groups           = G,
            Sigma_spatial_init = Sigma_spatial,
            control            = vcmm_control(
              sigma_eps       = 0.6,
              sigma_alpha     = sqrt(0.5),
              update_variance = TRUE))
fit

## ----sigma-2x2----------------------------------------------------------------
Sigma_2x2_hat <- fit$re_cov_state$Sigma_left
round(Sigma_2x2_hat, 3)

# Correlation between origin and destination effects
corr_OD <- Sigma_2x2_hat[1, 2] /
           sqrt(Sigma_2x2_hat[1, 1] * Sigma_2x2_hat[2, 2])
round(corr_OD, 3)

## ----ranef--------------------------------------------------------------------
alpha_hat <- fit$alpha
M_hat <- matrix(alpha_hat, nrow = G, ncol = 2L)
colnames(M_hat) <- c("origin", "dest")
rownames(M_hat) <- paste0("region_", seq_len(G))
round(M_hat, 3)

## ----ranef-plot, fig.cap = "Estimated origin and destination effects per region."----
matplot(seq_len(G), M_hat, type = "b", pch = 19, lty = 1, lwd = 2,
        col = c("steelblue", "darkorange"),
        xlab = "Region", ylab = "Random effect")
abline(h = 0, lty = 2, col = "grey60")
legend("topright", c("origin", "dest"),
       col = c("steelblue", "darkorange"), pch = 19, lwd = 2, bty = "n")

## ----vcoef, fig.cap = "Estimated time-varying effect of wage_diff on log flow."----
t_grid <- seq(0, 1, length.out = 100L)
vc     <- varying_coef(fit, t_new = t_grid, k = 1L, se.fit = TRUE)

plot(t_grid, vc$fit, type = "l", lwd = 2, col = "steelblue",
     xlab = "t (year, normalised)",
     ylab = expression(hat(beta)[1](t)),
     ylim = range(vc$fit - 2 * vc$se.fit, vc$fit + 2 * vc$se.fit,
                  1.5 * sin(2 * pi * t_grid)))
polygon(c(t_grid, rev(t_grid)),
        c(vc$fit + 2 * vc$se.fit, rev(vc$fit - 2 * vc$se.fit)),
        col = adjustcolor("steelblue", alpha.f = 0.25), border = NA)
lines(t_grid, 1.5 * sin(2 * pi * t_grid),
      col = "red", lty = 2, lwd = 2)
legend("topright", c("estimate", "truth"),
       col = c("steelblue", "red"), lty = c(1, 2), lwd = 2, bty = "n")

## ----distributed-od, eval = FALSE---------------------------------------------
# # Split N obs across 3 nodes
# node_id <- sample.int(3L, N, replace = TRUE)
# splits  <- split(seq_len(N), node_id)
# 
# design <- build_vcmm_design(X = od$wage_diff, t = od$t)
# X_d    <- design$X_design
# 
# summaries <- lapply(splits, function(idx)
#   node_summary(od$log_flow[idx],
#                X_d[idx, , drop = FALSE],
#                Z[idx, , drop = FALSE]))
# 
# fit_dist <- fit_from_summaries(
#   summaries,
#   penalty            = design$penalty,
#   control            = vcmm_control(sigma_eps = 0.6,
#                                     sigma_alpha = sqrt(0.5),
#                                     update_variance = TRUE),
#   method             = "csl",
#   re_cov             = "kronecker",
#   n_groups           = G,
#   Sigma_spatial_init = Sigma_spatial,
#   rowsum_constant    = 2
# )
# 
# # Same answer as the pooled fit above, up to BLAS noise
# max(abs(fit$beta  - fit_dist$beta))
# max(abs(fit$alpha - fit_dist$alpha))