GWR Train Network: Data Overview
1. About this report
This report summarizes GWR schedule records and constructs a network of scheduled stopping locations. It does not analyze actual delays.
Two locations are neighbors when they appear as consecutive stops in at least one included schedule. Connections are undirected.
Express services may skip intermediate stations, so these are service connections rather than physical track connections.
Scheduled stopping locations may include operational stops, depots, and other non-passenger locations.
The extract can contain different schedule versions and validity periods. Counts represent schedule records, not daily train volumes. The network combines connections across the included records.
2. Load the data
schedule_file <- "toc-full.gz"
corpus_file <- "CORPUSExtract.json.gz"
stopifnot(
file.exists(schedule_file),
file.exists(corpus_file)
)
# Extract one nonblank text value.
txt <- function(x) {
if (is.null(x) || length(x) == 0L) {
return(NA_character_)
}
value <- trimws(as.character(x[[1]]))
if (is.na(value) || !nzchar(value)) {
NA_character_
} else {
value
}
}
# Return the first available nonblank value.
first_text <- function(...) {
values <- vapply(list(...), txt, character(1))
values <- values[!is.na(values)]
if (length(values)) values[1] else NA_character_
}
clean_code <- function(x) {
x <- toupper(trimws(x))
x[x == ""] <- NA_character_
x
}read_gwr <- function(path) {
con <- gzfile(path, open = "rt")
on.exit(close(con))
output <- list()
k <- 0L
seen <- 0L
operators <- character()
repeat {
lines <- readLines(con, n = 2000L, warn = FALSE)
if (!length(lines)) break
lines <- lines[nzchar(trimws(lines))]
for (line in lines) {
record <- tryCatch(
jsonlite::fromJSON(line, simplifyVector = FALSE),
error = function(e) {
stop(
"Could not read the schedule as newline-delimited JSON. ",
"Check that this is the JSON full extract."
)
}
)
schedule <- record$JsonScheduleV1
if (is.null(schedule)) next
seen <- seen + 1L
if (seen %% 10000L == 0L) {
cat(
"Schedules checked:", seen,
"| GWR kept:", k, "\n"
)
flush.console()
}
segment <- schedule$schedule_segment
operator <- clean_code(first_text(
schedule$atoc_code,
segment$atoc_code
))
operators <- union(operators, operator)
if (is.na(operator) || operator != "GW") next
if (identical(
toupper(txt(schedule$transaction_type)),
"DELETE"
)) next
k <- k + 1L
output[[k]] <- schedule
}
}
if (seen == 0L) {
stop("No JsonScheduleV1 records found.")
}
if (!length(output)) {
stop(
"No GWR schedules found. Operator codes found: ",
paste(operators, collapse = ", ")
)
}
cat("Finished. GWR schedule records retained:", k, "\n")
output
}
schedules <- read_gwr(schedule_file)# Binary connection avoids the readBin connection error.
read_corpus <- function(path) {
con <- gzfile(path, open = "rb")
on.exit(close(con))
jsonlite::fromJSON(con, simplifyVector = FALSE)
}
corpus_raw <- read_corpus(corpus_file)
if (is.null(corpus_raw$TIPLOCDATA)) {
stop("Expected TIPLOCDATA in the CORPUS file.")
}
# Normalize field names so uppercase/lowercase both work.
locations <- map_dfr(corpus_raw$TIPLOCDATA, function(x) {
names(x) <- tolower(names(x))
tibble(
tiploc = txt(x$tiploc),
location_name = first_text(
x$nlcdesc,
x$nlcdesc16,
x$fn,
x$description,
x$tiploc
)
)
}) |>
mutate(tiploc = clean_code(tiploc)) |>
filter(!is.na(tiploc)) |>
distinct(tiploc, .keep_all = TRUE)
if (!nrow(locations)) {
stop(
"No CORPUS location codes were extracted. ",
"Run names(corpus_raw$TIPLOCDATA[[1]]) to inspect the fields."
)
}3. Prepare schedule and stop tables
# One row per schedule record.
schedule_info <- tibble(
schedule_id = seq_along(schedules),
train_uid = vapply(
schedules,
function(x) txt(x$CIF_train_uid),
character(1)
),
start_date = vapply(
schedules,
function(x) txt(x$schedule_start_date),
character(1)
),
end_date = vapply(
schedules,
function(x) txt(x$schedule_end_date),
character(1)
),
stp_indicator = vapply(
schedules,
function(x) txt(x$CIF_stp_indicator),
character(1)
)
) |>
filter(is.na(stp_indicator) | stp_indicator != "C")
# Cancellation records are excluded. Other schedule versions
# remain included in this overview.# Faster version: create one table per schedule,
# rather than one table per location.
calls_list <- vector("list", nrow(schedule_info))
for (n in seq_len(nrow(schedule_info))) {
i <- schedule_info$schedule_id[n]
locs <- schedules[[i]]$schedule_segment$schedule_location
calls_list[[n]] <- tibble(
schedule_id = rep(i, length(locs)),
sequence = seq_along(locs),
tiploc = vapply(
locs, function(x) txt(x$tiploc_code), character(1)
),
arrival = vapply(
locs, function(x) txt(x$arrival), character(1)
),
departure = vapply(
locs, function(x) txt(x$departure), character(1)
),
pass = vapply(
locs, function(x) txt(x$pass), character(1)
)
)
if (n %% 1000L == 0L) {
cat(
"Schedules processed:", n,
"of", nrow(schedule_info), "\n"
)
flush.console()
}
}
calls <- bind_rows(calls_list)
rm(calls_list)
if (!nrow(calls)) {
stop("No schedule locations were found.")
}# Keep arrivals/departures, including origins and destinations.
# Exclude passing-only timing points.
stops <- calls |>
mutate(tiploc = clean_code(tiploc)) |>
filter(
!is.na(tiploc),
!is.na(arrival) | !is.na(departure)
) |>
left_join(locations, by = "tiploc") |>
mutate(location_name = coalesce(location_name, tiploc)) |>
arrange(schedule_id, sequence)
if (!nrow(stops)) {
stop("No scheduled stops were found.")
}
unmatched_locations <- stops |>
distinct(tiploc) |>
anti_join(locations, by = "tiploc")
if (nrow(unmatched_locations) == n_distinct(stops$tiploc)) {
stop(
"All location codes failed to match CORPUS. ",
"Check the CORPUS fields before continuing."
)
}4. Basic data summary
overview <- tibble(
Measure = c(
"Included GWR schedule records",
"Unique train UIDs",
"Unique stopping locations",
"Scheduled stop entries",
"Locations without a CORPUS match"
),
Value = c(
nrow(schedule_info),
n_distinct(schedule_info$train_uid, na.rm = TRUE),
n_distinct(stops$tiploc),
nrow(stops),
nrow(unmatched_locations)
)
)
kable(overview, format.args = list(big.mark = ","))| Measure | Value |
|---|---|
| Included GWR schedule records | 39,610 |
| Unique train UIDs | 21,284 |
| Unique stopping locations | 488 |
| Scheduled stop entries | 279,644 |
| Locations without a CORPUS match | 0 |
kable(
stops |>
select(
schedule_id, sequence, tiploc,
location_name, arrival, departure
) |>
head(15),
caption = "Example scheduled stops"
)| schedule_id | sequence | tiploc | location_name | arrival | departure |
|---|---|---|---|---|---|
| 1 | 1 | PADTON | PADDINGTON LONDON | NA | 2333 |
| 1 | 13 | RDNGSTN | READING | 0014H | 0016H |
| 1 | 17 | DIDCOTP | DIDCOT PARKWAY | 0030H | 0032 |
| 1 | 23 | SDON | SWINDON | 0048 | 0050 |
| 1 | 25 | CHIPNHM | CHIPPENHAM | 0100 | 0101H |
| 1 | 29 | BATHSPA | BATH SPA | 0112H | 0114H |
| 1 | 32 | BRSTLTM | BRISTOL TEMPLE MEADS | 0126 | NA |
| 2 | 1 | EXETRSD | EXETER ST DAVIDS | NA | 1708 |
| 2 | 2 | DAWLSHW | DAWLISH WARREN | 1719 | 1720 |
| 2 | 3 | DAWLISH | DAWLISH | 1723 | 1724 |
| 2 | 4 | TEINMTH | TEIGNMOUTH | 1728 | 1729 |
| 2 | 5 | NABT | NEWTON ABBOT | 1735 | 1737 |
| 2 | 8 | TOTNES | TOTNES | 1749H | 1750H |
| 2 | 11 | IVYBDGE | IVYBRIDGE | 1805H | 1806H |
| 2 | 15 | PLYMTH | PLYMOUTH | 1820 | NA |
if (nrow(unmatched_locations) > 0L) {
kable(
head(unmatched_locations, 20),
caption = "Unmatched location codes: first 20"
)
}5. Most frequently listed stopping locations
Counts describe appearances in the schedule extract, not the number of trains stopping on a particular day.
stop_counts <- stops |>
count(tiploc, location_name, name = "scheduled_calls") |>
mutate(
label = if_else(
location_name == tiploc,
tiploc,
paste0(location_name, " [", tiploc, "]")
)
) |>
arrange(desc(scheduled_calls))
stop_counts |>
slice_head(n = 20) |>
ggplot(aes(
x = reorder(label, scheduled_calls),
y = scheduled_calls
)) +
geom_col(fill = "#2878A0") +
coord_flip() +
labs(
title = "Top 20 locations by schedule appearances",
x = NULL,
y = "Scheduled stop entries"
)
6. Number of stops per schedule
stops_per_schedule <- stops |>
count(schedule_id, name = "number_of_stops")
ggplot(stops_per_schedule, aes(number_of_stops)) +
geom_histogram(
binwidth = 1,
boundary = 0.5,
fill = "#2878A0",
color = "white"
) +
labs(
title = "Number of stops per schedule record",
x = "Scheduled stops",
y = "Schedule records"
)
7. Construct the connections
Repeated pairs and reversed pairs become one undirected connection. A location is never connected to itself.
pairs <- stops |>
group_by(schedule_id) |>
arrange(sequence, .by_group = TRUE) |>
mutate(next_stop = lead(tiploc)) |>
ungroup() |>
filter(
!is.na(next_stop),
tiploc != next_stop
)
edges <- pairs |>
transmute(
from = pmin(tiploc, next_stop),
to = pmax(tiploc, next_stop)
) |>
distinct()
vertices <- stops |>
distinct(tiploc, location_name) |>
arrange(tiploc) |>
rename(name = tiploc)
g <- graph_from_data_frame(
d = edges,
directed = FALSE,
vertices = vertices
)
if (ecount(g) == 0L) {
stop("No connections were found.")
}
kable(
tibble(
Measure = c(
"Stopping locations",
"Undirected connections"
),
Value = c(vcount(g), ecount(g))
)
)| Measure | Value |
|---|---|
| Stopping locations | 488 |
| Undirected connections | 1012 |
8. Build A, D, and L
- Adjacency matrix A: 1 for neighbors, 0 otherwise.
- Degree matrix D: neighbor counts on the diagonal; 0 elsewhere.
- Laplacian matrix L: D minus A.
All three matrices use the same location order.
A <- as_adjacency_matrix(g, sparse = TRUE)
diag(A) <- 0
A <- Matrix::drop0(A)
D <- Diagonal(
x = as.numeric(Matrix::rowSums(A))
)
dimnames(D) <- dimnames(A)
L <- D - A
# Verify construction.
stopifnot(
isSymmetric(A),
all(diag(A) == 0),
all(A@x == 1),
all(Matrix::rowSums(L) == 0),
sum(Matrix::rowSums(A)) == 2 * ecount(g)
)
kable(
tibble(
Matrix = c("A", "D", "L"),
Rows = c(nrow(A), nrow(D), nrow(L)),
Columns = c(ncol(A), ncol(D), ncol(L))
),
caption = "Full matrix dimensions"
)| Matrix | Rows | Columns |
|---|---|---|
| A | 488 | 488 |
| D | 488 | 488 |
| L | 488 | 488 |
Small matrix preview
To show actual connections, the preview contains the location with the most neighbors and up to nine of its neighbors.
The displayed D and L entries retain degrees from the full network. Therefore, row sums of the displayed portion of L need not be zero; the full L has zero row sums.
degree_table <- tibble(
tiploc = V(g)$name,
location_name = V(g)$location_name,
neighbors = as.integer(degree(g))
) |>
mutate(
label = if_else(
location_name == tiploc,
tiploc,
paste0(location_name, " [", tiploc, "]")
)
) |>
arrange(desc(neighbors), tiploc)
hub <- degree_table$tiploc[1]
hub_neighbors <- as_ids(
igraph::neighbors(g, hub)
)
preview_ids <- c(
hub,
head(sort(hub_neighbors), 9)
)
kable(
vertices |>
filter(name %in% preview_ids) |>
arrange(match(name, preview_ids)),
caption = "Location names for the matrix preview"
)| name | location_name |
|---|---|
| RDNGSTN | READING |
| ASCOT | ASCOT |
| BATHSPA | BATH SPA |
| BEDYN | BEDWYN |
| BEDYNRS | BEDWYN REVERSING SIDING |
| BRSTLTM | BRISTOL TEMPLE MEADS |
| BRSTPWY | BRISTOL PARKWAY |
| BSNGSTK | BASINGSTOKE |
| CCARY | CASTLE CARY |
| CHIPNHM | CHIPPENHAM |
kable(
as.matrix(A[preview_ids, preview_ids, drop = FALSE]),
caption = "Adjacency matrix A: selected locations"
)| RDNGSTN | ASCOT | BATHSPA | BEDYN | BEDYNRS | BRSTLTM | BRSTPWY | BSNGSTK | CCARY | CHIPNHM | |
|---|---|---|---|---|---|---|---|---|---|---|
| RDNGSTN | 0 | 1 | 1 | 1 | 1 | 1 | 1 | 1 | 1 | 1 |
| ASCOT | 1 | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 0 |
| BATHSPA | 1 | 0 | 0 | 0 | 0 | 1 | 1 | 0 | 0 | 1 |
| BEDYN | 1 | 0 | 0 | 0 | 1 | 1 | 0 | 0 | 0 | 0 |
| BEDYNRS | 1 | 0 | 0 | 1 | 0 | 0 | 0 | 0 | 0 | 0 |
| BRSTLTM | 1 | 0 | 1 | 1 | 0 | 0 | 1 | 0 | 0 | 0 |
| BRSTPWY | 1 | 0 | 1 | 0 | 0 | 1 | 0 | 0 | 0 | 0 |
| BSNGSTK | 1 | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 0 |
| CCARY | 1 | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 0 |
| CHIPNHM | 1 | 0 | 1 | 0 | 0 | 0 | 0 | 0 | 0 | 0 |
kable(
as.matrix(D[preview_ids, preview_ids, drop = FALSE]),
caption = "Degree matrix D: selected locations"
)| RDNGSTN | ASCOT | BATHSPA | BEDYN | BEDYNRS | BRSTLTM | BRSTPWY | BSNGSTK | CCARY | CHIPNHM | |
|---|---|---|---|---|---|---|---|---|---|---|
| RDNGSTN | 63 | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 0 |
| ASCOT | 0 | 3 | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 0 |
| BATHSPA | 0 | 0 | 14 | 0 | 0 | 0 | 0 | 0 | 0 | 0 |
| BEDYN | 0 | 0 | 0 | 8 | 0 | 0 | 0 | 0 | 0 | 0 |
| BEDYNRS | 0 | 0 | 0 | 0 | 5 | 0 | 0 | 0 | 0 | 0 |
| BRSTLTM | 0 | 0 | 0 | 0 | 0 | 39 | 0 | 0 | 0 | 0 |
| BRSTPWY | 0 | 0 | 0 | 0 | 0 | 0 | 32 | 0 | 0 | 0 |
| BSNGSTK | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 2 | 0 | 0 |
| CCARY | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 10 | 0 |
| CHIPNHM | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 6 |
kable(
as.matrix(L[preview_ids, preview_ids, drop = FALSE]),
caption = "Laplacian matrix L: selected locations"
)| RDNGSTN | ASCOT | BATHSPA | BEDYN | BEDYNRS | BRSTLTM | BRSTPWY | BSNGSTK | CCARY | CHIPNHM | |
|---|---|---|---|---|---|---|---|---|---|---|
| RDNGSTN | 63 | -1 | -1 | -1 | -1 | -1 | -1 | -1 | -1 | -1 |
| ASCOT | -1 | 3 | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 0 |
| BATHSPA | -1 | 0 | 14 | 0 | 0 | -1 | -1 | 0 | 0 | -1 |
| BEDYN | -1 | 0 | 0 | 8 | -1 | -1 | 0 | 0 | 0 | 0 |
| BEDYNRS | -1 | 0 | 0 | -1 | 5 | 0 | 0 | 0 | 0 | 0 |
| BRSTLTM | -1 | 0 | -1 | -1 | 0 | 39 | -1 | 0 | 0 | 0 |
| BRSTPWY | -1 | 0 | -1 | 0 | 0 | -1 | 32 | 0 | 0 | 0 |
| BSNGSTK | -1 | 0 | 0 | 0 | 0 | 0 | 0 | 2 | 0 | 0 |
| CCARY | -1 | 0 | 0 | 0 | 0 | 0 | 0 | 0 | 10 | 0 |
| CHIPNHM | -1 | 0 | -1 | 0 | 0 | 0 | 0 | 0 | 0 | 6 |
9. Locations with the most neighbors
degree_table |>
slice_head(n = 20) |>
ggplot(aes(
x = reorder(label, neighbors),
y = neighbors
)) +
geom_col(fill = "#32936F") +
coord_flip() +
labs(
title = "Top 20 locations by number of neighbors",
x = NULL,
y = "Distinct neighboring stops"
)
10. Adjacency heatmap
This displays the 25 locations with the most neighbors. Connections to locations outside the selection are not displayed.
heat_ids <- head(degree_table$tiploc, 25)
heat_data <- as.data.frame(
as.table(
as.matrix(A[heat_ids, heat_ids, drop = FALSE])
)
)
names(heat_data) <- c("from", "to", "connected")
heat_data$from <- factor(
heat_data$from,
levels = heat_ids
)
heat_data$to <- factor(
heat_data$to,
levels = rev(heat_ids)
)
ggplot(
heat_data,
aes(from, to, fill = factor(connected))
) +
geom_tile(color = "grey85", linewidth = 0.2) +
scale_fill_manual(
values = c("0" = "white", "1" = "#2878A0"),
limits = c("0", "1"),
labels = c("No", "Yes"),
name = "Neighbors"
) +
coord_equal() +
labs(
title = "Adjacency matrix: 25 selected locations",
x = "Location code",
y = "Location code"
) +
theme(
panel.grid = element_blank(),
axis.text.x = element_text(
angle = 90,
hjust = 1,
vjust = 0.5
)
)
11. Full network diagram
Dots represent stopping locations and lines represent connections. Larger dots have more neighbors.
The layout is schematic, not geographic. Only the ten locations with the most neighbors are labeled.
set.seed(123)
label_ids <- head(degree_table$tiploc, 10)
network_labels <- ifelse(
V(g)$name %in% label_ids,
V(g)$location_name,
NA_character_
)
network_layout <- layout_with_fr(g)
plot(
g,
layout = network_layout,
vertex.size = 3 + sqrt(degree(g)),
vertex.color = "#2878A0",
vertex.frame.color = NA,
vertex.label = network_labels,
vertex.label.cex = 0.65,
vertex.label.color = "black",
vertex.label.dist = 0.5,
edge.color = adjustcolor("grey45", alpha.f = 0.35),
edge.width = 0.8,
main = "GWR scheduled-stop network"
)
12. Smaller network view
This shows the same locations used in the matrix preview. Only connections among those locations are displayed.
small_g <- induced_subgraph(g, vids = preview_ids)
set.seed(123)
plot(
small_g,
layout = layout_with_fr(small_g),
vertex.size = 9,
vertex.color = "#32936F",
vertex.frame.color = NA,
vertex.label = V(small_g)$location_name,
vertex.label.cex = 0.75,
vertex.label.color = "black",
vertex.label.dist = 1,
edge.color = "grey55",
edge.width = 1.5,
main = "Selected stopping locations and their connections",
margin = 0.2
)
13. Save the results
The RDS file preserves the full sparse matrices and location labels. CSV versions are also saved for viewing outside R.
dir.create("network_output", showWarnings = FALSE)
saveRDS(
list(
A = A,
D = D,
L = L,
locations = vertices,
edges = edges
),
"network_output/network_matrices.rds"
)
write.csv(
as.matrix(A),
"network_output/adjacency_matrix_A.csv",
row.names = TRUE
)
write.csv(
as.matrix(D),
"network_output/degree_matrix_D.csv",
row.names = TRUE
)
write.csv(
as.matrix(L),
"network_output/laplacian_matrix_L.csv",
row.names = TRUE
)
write.csv(
vertices,
"network_output/location_lookup.csv",
row.names = FALSE
)
write.csv(
edges,
"network_output/connections.csv",
row.names = FALSE
)
write.csv(
degree_table,
"network_output/location_degrees.csv",
row.names = FALSE
)
write.csv(
overview,
"network_output/data_summary.csv",
row.names = FALSE
)
write.csv(
unmatched_locations,
"network_output/unmatched_locations.csv",
row.names = FALSE
)