/
check-fns.R
138 lines (110 loc) · 4.15 KB
/
check-fns.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
check_map_arg <- function (map) {
if (missing (map))
stop ("a non-null map must be provided", call. = FALSE)
if (!is (map, "ggplot"))
stop ("map must be a ggplot2 object", call. = FALSE)
}
#' get type of geometry object from either sf or sp objects
#'
#' @note \code{sf} objects return singular nouns ('polygon', 'point'), while
#' \code{sp} return plurals ('polygons', 'points')
#'
#' @noRd
get_obj_type <- function (obj) {
if (is (obj, "sf")) {
if (!inherits(obj$geometry, "sfc"))
warning("object class is sf, but the geometry column class is '",
toString(class(obj$geometry)),
"' instead of 'sfc'.\n",
"This can occur e.g. after subsetting sf objects ",
"without the sf package loaded.")
i <- which (grepl ("sfc_", class (obj$geometry)))
obj_type <- tolower (strsplit (class (obj$geometry) [i],
"sfc_") [[1]] [2])
} else {
obj_type <- tolower (strsplit (strsplit (class (obj),
"Spatial") [[1]] [2],
"DataFrame") [[1]] [1])
}
return (obj_type)
}
#' capitalise first letter of word
#'
#' @note does same as stringi::stri_trans_totitle
#'
#' @noRd
cap_first <- function (x) {
paste0 (toupper (substring (x, 1, 1)), substring (x, 2, nchar (x)))
}
check_obj_arg <- function (obj) {
if (missing (obj))
stop ("obj must be provided", call. = FALSE)
if (!(is (obj, "Spatial") | is (obj, "sf")))
stop ("obj must be a spatial object", call. = FALSE)
}
check_col_arg <- function (col) {
if (missing (col))
stop ("a non-null col must be provided")
# Note col2rbg (NA) = white
tryCatch (
col2rgb (col),
error = function (e) {
e$message <- paste0 ("Invalid colour: ", col)
stop (e)
})
}
check_bbox_arg <- function (bbox) {
if (missing (bbox))
stop ("bbox must be provided")
if (is (bbox, "sf")) { # sf obj submitted to osm_basemap
if (is (bbox$geometry, "sfc_LINESTRING") |
is (bbox$geometry, "sfc_POINT"))
xy <- do.call (rbind, bbox$geometry)
else if (is (bbox$geometry, "sfc_POLYGON"))
xy <- do.call (rbind, lapply (bbox$geometry, function (i) i [[1]]))
else if (is (bbox$geometry, "sfc_MULTIPOLYGON") |
is (bbox$geometry, "sfc_MULTILINESTRING"))
xy <- do.call (rbind, lapply (bbox$geometry,
function (i) i [[1]] [[1]]))
bbox <- t (apply (xy, 2, range))
rownames (bbox) <- c ("x", "y")
colnames (bbox) <- c ("min", "max")
}
if (!is.numeric (bbox))
stop ("bbox is not numeric")
if (length (bbox) < 4)
stop ("bbox must have length = 4")
if (length (bbox) > 4) {
warning ("bbox has length > 4; only first 4 elements will be used")
bbox <- matrix (bbox [1:4], 2, 2)
}
return (bbox)
}
check_structures_arg <- function (structures) {
if (!missing (structures)) {
if (!is.data.frame (structures))
stop ("structures must be a data frame")
ns <- c ("structure", "key", "value", "suffix", "cols")
if (!all (names (structures) == ns))
stop ("structures not in recognised format")
}
}
#' generic function to check argument conversion to given function type
#'
#' @noRd
check_arg <- function (arg, arg_name, fn_type, na_okay = FALSE) {
if (missing (arg))
stop (paste (arg_name, "must be provided"))
else if (length (arg) == 0)
stop (paste (arg_name, "can not be NULL"))
else if (!na_okay & is.na (arg))
stop (paste (arg_name, "can not be NA"))
adj <- tryCatch (
do.call (paste0 ("as.", fn_type), list (arg)),
warning = function (w) {
w$message <- paste (arg_name,
"can not be coerced to",
fn_type)
})
invisible (adj)
}