/
class_spflow_network.R
465 lines (397 loc) · 14.3 KB
/
class_spflow_network.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
#' @include class_generics_and_maybes.R
#' @title Class spflow_network
#'
#' @description
#' An S4 class that contains all information on a spatial network which is
#' composed by a set of nodes that are linked by some neighborhood relation.
#' The class is constructed by the [spflow_network()] function.
#'
#' @details
#' The data on each node is stored in a data.frame, where each node must be
#' uniquely identified by a key.
#' The neighborhood relations are described by a matrix that satisfies the
#' usual assumptions of the spatial weight matrix in spatial econometric models.
#' In most cases each node will only neighbor to a few others, in which case
#' the neighborhood matrix is represented as a [sparseMatrix()].
#' Function to create spatial neighborhood matrices can be found in the
#' **spdep** package.
#'
#'
#' @slot id_net
#' A character that serves as an identifier for the set of nodes
#' @slot node_data
#' A data.frame that contains all information describing the nodes
#' @slot node_neighborhood
#' A matrix that describes the neighborhood relations of the nodes
#'
#' @param object A spflow_network-class
#' @param value An object to replace the existing id/data/neighborhood
#' @importClassesFrom Matrix Matrix
#' @name spflow_network-class
#' @export
setClass("spflow_network",
slots = c(
id_net = "character",
node_neighborhood = "maybe_Matrix",
node_data = "maybe_data.frame"))
# ---- Methods ----------------------------------------------------------------
# ---- ... dat ----------------------------------------------------------------
#' @rdname spflow_network-class
#' @export
#' @examples
#' ## access the data describing the nodes
#' new_dat <- dat(germany_net)
#'
setMethod(
f = "dat",
signature = "spflow_network",
function(object) {
return(object@node_data)
})
# ---- ... dat <- -------------------------------------------------------------
#' @rdname spflow_network-class
#' @param ... not used, required for consistent argument matching
#' (see https://bugs.r-project.org/show_bug.cgi?id=18538)
#' @inheritParams spflow_network
setReplaceMethod(
f = "dat",
signature = "spflow_network",
function(object,
...,
node_key_column,
node_coord_columns,
derive_coordinates = FALSE,
prefer_lonlat = TRUE,
value) {
value <- simplfy2df(value, derive_coordinates, prefer_lonlat)
check <- "The node_key_column is not available or not unique!"
if (missing(node_key_column))
node_key_column <- attr_key_nodes(value)
if (is.null(node_key_column))
node_key_column <- attr_key_nodes(dat(object))
assert(sum(node_key_column == names(value)) == 1, check)
attr_key_nodes(value) <- node_key_column
check <- "The nodes are not uniquely identfyed!"
new_keys <- factor_in_order(value[[node_key_column]])
assert(length(new_keys) == length(levels(new_keys)), check)
value[[node_key_column]] <- new_keys
check <- "The node keys are updated and may imply a diffrent ordering!"
if (!is.null(dat(object))) {
old_keys <- dat(object)[[attr_key_nodes(dat(object))]]
assert(identical(old_keys, new_keys), check, warn = TRUE)
}
check <- "The node_coord_columns are not found!"
if (missing(node_coord_columns))
node_coord_columns <- attr_coord_col(value)
if (is.null(node_key_column))
node_coord_columns <- attr_coord_col(dat(object))
if (!is.null(node_coord_columns))
attr_coord_col(value) <- node_coord_columns
assert(all(node_coord_columns %in% names(value)), check)
object@node_data <- value
validObject(object)
return(object)
})
# ---- ... id -----------------------------------------------------------------
#' @rdname spflow_network-class
#' @examples
#' # access the id of the network
#' germany_net2 <- germany_net
#' id(germany_net2)
#' id(germany_net2) <- "Germany"
#'
setMethod(
f = "id",
signature = "spflow_network",
function(object) {
return(object@id_net)
})
# ---- ... id <- --------------------------------------------------------------
#' @rdname spflow_network-class
#' @export
setReplaceMethod(
f = "id",
signature = "spflow_network",
function(object, value) {
assert(valid_net_id(value), "The id is invalid!")
object@id_net <- value
return(object)
})
# ---- ... neighborhood -------------------------------------------------------
#' @rdname spflow_network-class
#' @export
#' @examples
#' # access the neighborhood matrix of the nodes
#' neighborhood(germany_net)
#'
setMethod(
f = "neighborhood",
signature = "spflow_network",
function(object) return(object@node_neighborhood))
# ---- ... neighborhood <- ----------------------------------------------------
#' @rdname spflow_network-class
setReplaceMethod(
f = "neighborhood",
signature = "spflow_network",
function(object, value) {
if (!is.null(value)) {
value <- try_coercion(value,"Matrix")
assert(has_equal_elements(c(dim(value), nnodes(object))),
"Replacement neighborhood musst have %s rows and %s columns!",
nnodes(object), nnodes(object))
value <- normalize_neighborhood(value)
}
object@node_neighborhood <- value
validObject(object)
return(object)
})
# ---- ... nnodes -------------------------------------------------------------
#' @rdname spflow_network-class
#' @export
#' @examples
#' # access the number of nodes inside the network
#' nnodes(germany_net)
#'
setMethod(
f = "nnodes",
signature = "spflow_network",
function(object) {
dims <- c(nrow(object@node_data), nrow(object@node_neighborhood))
return(dims %|!|% max)
})
# ---- ... show ---------------------------------------------------------------
#' @keywords internal
setMethod(
f = "show",
signature = "spflow_network",
function(object){
cat("Spatial network nodes with id:",id(object))
cat("\n")
cat(print_line(50))
has_count <- !is.null(nnodes(object))
if (has_count) {
cat("\nNumber of nodes:", nnodes(object))
}
has_neighborhood <- !is.null(neighborhood(object))
if (has_neighborhood) {
nb_links <- nnzero(neighborhood(object))
cat("\nAverage number of links per node:",
round(nb_links/nnodes(object),3)
)
cat("\nDensity of the neighborhood matrix:",
format_percent(nb_links/(nnodes(object)^2)),
"(non-zero connections)"
)
}
has_data <- !is.null(dat(object))
if (has_data) {
cat("\n\nData on nodes:\n")
pprint_df(dat(object))
}
cat("\n")
invisible(object)
})
# ---- ... update_dat ---------------------------------------------------------
#' @rdname spflow_network-class
#' @param new_dat A data.frame
#' @export
setMethod(
f = "update_dat",
signature = "spflow_network",
function(object, new_dat) {
assert(is_column_subset(dat(object), new_dat),
'All columns in new_dat must exist and have the same
type as in the node_data of "%s"!', id(object))
new_cols <- colnames(new_dat)
keys <- attr_key_nodes(dat(object))
assert(all(keys %in% new_cols),
'The new_dat for spflow_network with id "%s"
must have the column %s to identify the nodes!',
id(object), deparse(keys))
new_dat[[keys]] <- factor(new_dat[[keys]], levels(dat(object)[[keys]]))
assert(!any(is.na(new_dat)) && has_distinct_elements(new_dat[[keys]]),
'Some keys in new_dat are duplicated or do not correpond to
observations in spflow_network with id "%s"!',
id(object))
new_dat_index <- as.numeric(new_dat[[keys]])
new_dat[[keys]] <- NULL
new_cols <- setdiff(colnames(new_dat), keys)
dat(object)[new_dat_index, new_cols] <- new_dat
return(object)
})
# ---- ... validity -----------------------------------------------------------
setValidity(
Class = "spflow_network",
function(object) {
check <- "The network id must contain only alphanumeric characters!"
if (!valid_net_id(id(object)))
return(check)
# verify details of the neighborhood
dim_nb <- dim(neighborhood(object))
if (!is.null(dim_nb)) {
check <- "The neighborhood matrix must be a square!"
if (!has_equal_elements(dim_nb))
return(check)
check <- "The neighborhood matrix must have zeros on the main diagonal!"
if (any(diag(neighborhood(object)) != 0))
return(check)
check <- "The neighborhood matrix must have non-negative entries!"
if (any(neighborhood(object) < 0))
return(check)
# TODO Should normalization of the nb matrix be required in spflow_network?
# check <- "The neighborhood matrix should be normalized!"
# spectral_radius <- attr_spectral_character(neighborhood(object))
# spectral_radius <- abs(spectral_radius[["LM"]])
# tol <- sqrt(.Machine$double.eps)
# if ((spectral_radius - tol) > 1)
# return(check)
# if ((spectral_radius + tol) < 1) {
# byrow_norm <- all(abs(rowSums(neighborhood(object)) - .5) == .5)
# if (!byrow_norm)
# return(check)
# }
}
# verify details of the node data
nnodes <- nrow(dat(object))
if (!is.null(nnodes)) {
check <- "The dimension of the neighborhood musst match the number of nodes!"
if (!has_equal_elements(c(nnodes, dim_nb)))
return(check)
check <- "The data musst have a key column!"
node_id_col <- attr_key_nodes(dat(object))
if (is.null(node_id_col))
return(check)
check <- "The key-column musst be a factor!"
node_ids <- dat(object)[[node_id_col]]
if (!is.factor(node_ids))
return(check)
check <- "All entries in the key-column musst be unique!"
if (!has_distinct_elements(node_ids))
return(check)
check <- "The node data musst be ordered according to the key-column!"
if (is.unsorted(node_ids))
return(check)
}
# object is valid
return(TRUE)
})
# ---- Constructors -----------------------------------------------------------
#' Create a [spflow_network-class()]
#'
#' @param id_net
#' A character that serves as an identifier for the set of nodes
#' @param node_data
#' A data.frame that contains all information describing the nodes
#' @param node_neighborhood
#' A matrix that describes the neighborhood of the nodes
#' @param node_key_column
#' A character indicating the column containing the identifiers for the nodes
#' @param derive_coordinates
#' A logical indicating whether there should be an attempt to infer the
#' coordinates from the node_data.
#' @param prefer_lonlat
#' A logical indicating whether the coordinates should be transformed to
#' longitude and latitude.
#' @param node_coord_columns
#' A character indicating the columns that represent the coordinates of the
#' nodes. For example `c("LON", "LAT")`.
#' @param normalize_byrow
#' A logical, if `TRUE` the neighborhood will be row-normalized, otherwise
#' it is scaled to have a spectral radius of one.
#' @return An S4 class of type [spflow_network-class()]
#'
#' @importClassesFrom Matrix Matrix
#' @export
#' @examples
#' spflow_network(
#' "germany",
#' spdep::nb2mat(spdep::poly2nb(germany_grid)),
#' as.data.frame(germany_grid),
#' "ID_STATE")
spflow_network <- function(
id_net,
node_neighborhood = NULL,
node_data = NULL,
node_key_column,
node_coord_columns,
derive_coordinates = missing(node_coord_columns),
prefer_lonlat = TRUE,
normalize_byrow = FALSE) {
# checks for validity of dimensions are done before the return
if (!is.null(node_neighborhood)) {
node_neighborhood <- try_coercion(node_neighborhood, "CsparseMatrix")
node_neighborhood <- normalize_neighborhood(node_neighborhood, normalize_byrow)
}
nodes <- new("spflow_network",
id_net = id_net,
node_neighborhood = node_neighborhood,
node_data = NULL)
if (is.null(node_data))
return(nodes)
dat(object = nodes,
node_key_column = node_key_column,
node_coord_columns = if (missing(node_coord_columns)) NULL else node_coord_columns,
derive_coordinates = derive_coordinates,
prefer_lonlat = prefer_lonlat) <- node_data
validObject(nodes)
return(nodes)
}
# ---- Helpers ----------------------------------------------------------------
#' @keywords internal
attr_key_nodes <- function(df) {
attr(df, "node_key_column")
}
#' @keywords internal
`attr_key_nodes<-` <- function(df, value) {
assert(sum(value == names(df)) == 1, "
The node_key_column musst identfy exactly one column in the node_data!")
attr(df, "node_key_column") <- value
df
}
#' @keywords internal
attr_coord_col <- function(df, value) {
attr(df, "coord_columns")
}
#' @keywords internal
`attr_coord_col<-` <- function(df, value) {
assert(sum(value %in% names(df)) == length(value), "
The coord_columns musst unquily identfy the corresponding
column names in the node_data!")
attr(df, "coord_columns") <- value
df
}
#' @keywords internal
valid_net_id <- function(key) {
is_single_character(key) && grepl("^[[:alnum:]]+$",key)
}
#' @description Convert spatial data to a simple data.frame
#' @noRd
#' @keywords internal
simplfy2df <- function(df, derive_coord_cols = TRUE, prefer_lonlat = TRUE) {
dt_used <- inherits(df, "data.table")
sf_convertible <- inherits(df, "Spatial") || inherits(df, "sfc") || any(sapply(df, inherits, "sfc"))
if (sf_convertible && requireNamespace("sf", quietly = TRUE))
df <- sf::st_as_sf(df)
if (inherits(df, "Spatial"))
df <- as.data.frame(df@data)
if (inherits(df, "sf")) {
if (derive_coord_cols && requireNamespace("sf", quietly = TRUE)) {
coords <- sf::st_geometry(df)
coords <- suppressWarnings(sf::st_point_on_surface(coords))
if (!is.na(sf::st_crs(coords)) & prefer_lonlat)
coords <- sf::st_transform(coords, "WGS84")
coords <- prefix_columns(data.frame(sf::st_coordinates(coords)), "COORD_")
df <- cbind(sf::st_drop_geometry(df), coords)
names(df) <- make.names(names = names(df), unique = TRUE)
attr_coord_col(df) <- rev(names(df))[seq(ncol(coords), 1)]
} else {
df <- as.data.frame(df)
df <- Filter("is.atomic", df)
}
}
if (dt_used && requireNamespace("data.table", quietly = TRUE))
return(data.table::as.data.table(df))
if (inherits(df, "data.frame"))
return(df)
stop("Data cannot be converted to a data.frame!")
}