inst/doc/palsr.R

In palsr: Projected Actor Locations for Spatial Interaction Modeling

## ----setup, include = FALSE---------------------------------------------------
knitr::opts_chunk$set(
  collapse = TRUE,
  comment = "#>",
  fig.width = 7,
  fig.height = 4.5,
  dpi = 96
)
set.seed(1)

## ----load---------------------------------------------------------------------
library(palsr)

## ----data---------------------------------------------------------------------
data(nigeria_sim)
nigeria_sim
summary(nigeria_sim)

## ----build--------------------------------------------------------------------
raw <- data.frame(
  from = c("A", "A", "B"),
  to   = c("B", "C", "C"),
  when = as.Date(c("2001-01-01", "2001-06-01", "2002-01-01")),
  x    = c(7.1, 8.0, 7.5),
  y    = c(9.0, 9.4, 10.1)
)
pal_events(raw, actor1 = "from", actor2 = "to",
           time = "when", lon = "x", lat = "y")

## ----fit-one------------------------------------------------------------------
fit1 <- estimate_pals(nigeria_sim, model = "one")
fit1
coef(fit1)

## ----fit-four-----------------------------------------------------------------
fit4 <- estimate_pals(nigeria_sim, model = "four",
                      control = list(maxit = 60))
coef(fit4)

## ----project------------------------------------------------------------------
pal_2015 <- project_pals(nigeria_sim,
                         predict_time = as.Date("2015-01-01"),
                         params = fit1)
head(pal_2015)

## ----map, fig.alt = "Projected actor locations on 2015-01-01"-----------------
library(ggplot2)
ggplot(pal_2015, aes(lon, lat)) +
  geom_point(colour = "#2b6cb0", size = 2) +
  geom_text(aes(label = actor), vjust = -0.8, size = 3) +
  labs(title = "Projected actor locations, 2015-01-01",
       x = "Longitude", y = "Latitude") +
  theme_minimal()

## ----trajectory-map, fig.width = 7, fig.height = 4.5, fig.alt = "Projected trajectories of four actors over 2005-2016"----
actors <- c("G03", "G08", "G14", "G21")
dates  <- as.Date(sprintf("%d-01-01", seq(2005, 2016)))
traj   <- project_pals(nigeria_sim, actors = actors,
                       predict_time = dates, params = fit1)
traj   <- traj[!is.na(traj$lon), ]
ends   <- do.call(rbind, lapply(split(traj, traj$actor),
                                function(d) d[which.max(d$time), ]))

ggplot() +
  geom_point(data = nigeria_sim, aes(lon, lat),
             colour = "grey80", size = 0.5, alpha = 0.5) +
  geom_path(data = traj, aes(lon, lat, colour = actor), linewidth = 0.8,
            arrow = grid::arrow(length = grid::unit(0.18, "cm"), type = "closed")) +
  geom_point(data = traj, aes(lon, lat, colour = actor), size = 1.6) +
  geom_text(data = ends, aes(lon, lat, colour = actor, label = actor),
            nudge_y = 0.35, size = 3, show.legend = FALSE) +
  scale_colour_brewer(palette = "Dark2", name = "Actor") +
  labs(title = "Projected actor trajectories, 2005-2016",
       x = "Longitude", y = "Latitude") +
  coord_quickmap() +
  theme_minimal()

## ----predict-events-----------------------------------------------------------
targets <- nigeria_sim[nigeria_sim$time > as.Date("2014-01-01"), ]
scored  <- predict_event_locations(nigeria_sim, targets, fit1)
summary(scored$error_km)

## ----distance-----------------------------------------------------------------
dyads <- data.frame(actor1 = "G01", actor2 = "G02",
                    time = as.Date("2014-06-01"))
pal_distance(nigeria_sim, dyads, fit1, transform = "log")

## ----bootstrap----------------------------------------------------------------
bt <- bootstrap_pals(nigeria_sim, R = 10, model = "one", seed = 1)
summary(bt)

## ----rubin--------------------------------------------------------------------
q <- c(1.10, 0.95, 1.20, 1.05, 0.98)   # per-replicate estimates
u <- c(0.04, 0.05, 0.045, 0.038, 0.052) # per-replicate variances
pool_rubin(q, u, df = TRUE, dfcom = 100)