92.96% coverage — 370 of 398 tracked lines exercised by tests.
Select a file to inspect its source. + marks covered
lines; ! marks lines not exercised by tests.
Download line coverage (CSV) · Download Cobertura XML
Files
| File | Coverage | Covered | Missed | Total |
|---|---|---|---|---|
| R/check.R | 89.15% | 189 | 23 | 212 |
| R/inspect.R | 98.46% | 64 | 1 | 65 |
| R/read.R | 100.00% | 105 | 0 | 105 |
| R/values.R | 75.00% | 12 | 4 | 16 |
Source
R/check.R
Uncovered lines: 33, 67, 79, 83, 84, 105, 108, 134, 138, 139, 146, 147, 148, 153, 156, 158, 164, 190, 192, 194, 197, 223, 236.
View source
1 #' Read the model-definition schema
2 #' @param version Schema version; currently `"1.0.0"`.
3 #' @return The schema as a nested list. Unsupported versions raise `model_form_error`.
4 #' @details Uses the package's `form.model/schema/1` dialect, not JSON Schema.
5 #' @examples
6 #' form_schema()$contract_version
7 #' @export
8 form_schema <- function(version = "1.0.0") {
9 + text_arg(version, "version")
10 + if (!identical(version, "1.0.0")) abort_model("<schema>", "version", "unsupported schema version")
11 + read_yaml_data(form_resource("schema/model-1.0.0.yaml", "form.model"))
12 }
13
14 #' Check value attributes
15 #' @param x Any R object.
16 #' @return Whether attributes are absent or limited to names.
17 #' @keywords internal
18 + plain <- function(x) all(names(attributes(x)) %in% "names")
19 #' Check a schema scalar type
20 #' @param x Value to check without coercion.
21 #' @param type `string`, `boolean`, `number`, `integer`, or `scalar`.
22 #' @return Whether `x` is one nonmissing, unclassed value of the requested type.
23 #' Numbers must be finite; `scalar` accepts text, logicals and numbers.
24 #' @keywords internal
25 scalar_type <- function(x, type) {
26 + if (!is.atomic(x) || !plain(x) || length(x) != 1L || is.na(x)) return(FALSE)
27 + switch(type,
28 + string = is.character(x),
29 + boolean = is.logical(x),
30 + number = is.numeric(x) && is.finite(x),
31 + integer = is.numeric(x) && is.finite(x) && x == floor(x),
32 + scalar = is.character(x) || is.logical(x) || (is.numeric(x) && is.finite(x)),
33 ! FALSE)
34 }
35
36 #' Collect schema diagnostics
37 #' @param x Definition value.
38 #' @param node Schema node.
39 #' @param definitions Schema definitions for resolving references.
40 #' @param path Diagnostic location.
41 #' @param add Callback receiving `(path, message)`.
42 #' @return Invisible `NULL`; diagnostics are passed to `add`.
43 #' @keywords internal
44 schema_check <- function(x, node, definitions, path, add) {
45 + while (!is.null(node$ref)) node <- definitions[[node$ref]]
46 + if (!is.null(node$shorthand) && (!is.list(x) || is.null(names(x)))) {
47 + return(schema_check(x, node$shorthand, definitions, path, add))
48 }
49 + type <- node$type
50 + valid <- switch(type,
51 + mapping = is.list(x) && plain(x) && !is.null(names(x)),
52 + sequence = is.list(x) && plain(x) && is.null(names(x)),
53 + scalar_type(x, type))
54 + if (!valid) {
55 + add(path, paste0("expected ", type))
56 + return(invisible(NULL))
57 }
58 + if (type == "mapping") {
59 + keys <- names(x)
60 + for (key in unique(keys[duplicated(keys)])) add(paste0(path, ".", key), "duplicate property")
61 + if (!is.null(node$values)) {
62 + if (!is.null(node$min_items) && length(x) < node$min_items) {
63 + add(path, paste0("requires at least ", node$min_items, " items"))
64 }
65 + for (key in keys) {
66 + if (!is.null(node$key_pattern) && !grepl(node$key_pattern, key)) {
67 ! add(paste0(path, ".", key), "key does not match the required pattern")
68 }
69 + schema_check(x[[key]], node$values, definitions, paste0(path, ".", key), add)
70 }
71 } else {
72 + for (key in setdiff(keys, names(node$properties))) add(paste0(path, ".", key), "unsupported property")
73 + for (key in setdiff(unlist(node$required), keys)) add(paste0(path, ".", key), "missing required property")
74 + for (key in intersect(keys, names(node$properties))) {
75 + schema_check(x[[key]], node$properties[[key]], definitions, paste0(path, ".", key), add)
76 }
77 }
78 + } else if (type == "sequence") {
79 ! if (length(x) < node$min_items) add(path, paste0("requires at least ", node$min_items, " items"))
80 + for (i in seq_along(x)) schema_check(x[[i]], node$items, definitions, paste0(path, "[", i, "]"), add)
81 } else {
82 + if (!is.null(node$enum) && !x %in% unlist(node$enum)) add(path, "unsupported value")
83 ! if (!is.null(node$minimum) && x < node$minimum) add(path, paste0("must be >= ", node$minimum))
84 ! if (!is.null(node$min_length) && nchar(x) < node$min_length) add(path, "must not be empty")
85 + if (!is.null(node$pattern) && !grepl(node$pattern, x)) add(path, "does not match the required pattern")
86 }
87 + invisible(NULL)
88 }
89
90 #' Collect model consistency diagnostics
91 #' @param d Definition that has passed schema checking.
92 #' @param add Callback receiving `(path, message)`.
93 #' @return Diagnostics for references, constraints, dependencies and layouts,
94 #' passed to `add`.
95 #' @keywords internal
96 semantic_check <- function(d, add) {
97 + reference_groups <- !is.null(names(d$references))
98 + code_lists <- unlist(if (reference_groups) d$references$code_lists else d$references, use.names = FALSE)
99 + code_list_path <- if (reference_groups) "references.code_lists" else "references"
100 + registries <- unlist(if (reference_groups) d$references$registries else NULL, use.names = FALSE)
101 + for (i in which(duplicated(code_lists))) {
102 + add(paste0("$.", code_list_path, "[", i, "]"), paste0("duplicate code list: ", code_lists[[i]]))
103 }
104 + for (i in which(duplicated(registries))) {
105 ! add(paste0("$.references.registries[", i, "]"), paste0("duplicate registry: ", registries[[i]]))
106 }
107 + for (id in intersect(code_lists, registries))
108 ! add("$.references.registries", paste0("ID is also a code list: ", id))
109 + sheet_names <- names(d$sheets)
110 + if (anyDuplicated(tolower(sheet_names))) add("$.sheets", "duplicate workbook sheet names (case insensitive)")
111 + for (sheet_index in seq_along(d$sheets)) {
112 + sheet_name <- sheet_names[[sheet_index]]
113 + sheet <- d$sheets[[sheet_index]]
114 + layout <- sheet$layout
115 + table <- layout$kind == "table"
116 + layout_path <- paste0("$.sheets.", sheet_name, ".layout")
117 + if (table && is.null(layout$start_row)) add(paste0(layout_path, ".start_row"), "table requires start_row")
118 + if (!table && is.null(layout$column_count)) {
119 + add(paste0(layout_path, ".column_count"), "cell layout requires column_count")
120 }
121 + if (!table && "start_row" %in% names(layout)) {
122 + add(layout_path, "cell layout cannot have table row properties")
123 }
124 + if (!is.null(layout$row_count) && !is.null(layout$start_row) && layout$start_row > layout$row_count + 1) {
125 + add(paste0(layout_path, ".start_row"), "start row exceeds sheet extent")
126 }
127 + if (table && !is.null(layout$column_count) && layout$column_count != length(sheet$fields)) {
128 + add(paste0(layout_path, ".column_count"), "column count differs from field count")
129 }
130 + locations <- character()
131 + field_names <- names(sheet$fields)
132 + if (!is.null(sheet$primary_key)) {
133 + key_path <- paste0("$.sheets.", sheet_name, ".primary_key")
134 ! if (!table) add(key_path, "primary key requires a table layout")
135 + key <- unlist(sheet$primary_key, use.names = FALSE)
136 + for (i in seq_along(key)) {
137 + path <- paste0(key_path, "[", i, "]")
138 ! if (!key[[i]] %in% field_names) add(path, paste0("unknown field: ", key[[i]]))
139 ! if (duplicated(key)[[i]]) add(path, paste0("duplicate primary key field: ", key[[i]]))
140 }
141 }
142 + if (!is.null(sheet$parent_key)) {
143 + parent <- sheet$parent_key
144 + path <- paste0("$.sheets.", sheet_name, ".parent_key")
145 + child_key <- unlist(parent$fields, use.names = FALSE)
146 ! if (!table) add(path, "parent key requires a table layout")
147 ! if (anyDuplicated(child_key)) add(path, "duplicate parent key fields")
148 ! for (name in setdiff(child_key, field_names)) add(path, paste0("unknown child field: ", name))
149 + parent_index <- match(parent$sheet, sheet_names)
150 + if (is.na(parent_index)) {
151 + add(path, paste0("unknown parent sheet: ", parent$sheet))
152 } else {
153 ! if (parent_index >= sheet_index) add(path, "parent sheet must precede child sheet")
154 + target <- d$sheets[[parent$sheet]]
155 + target_key <- unlist(target$primary_key, use.names = FALSE)
156 ! if (!length(target_key)) add(path, "parent sheet must declare a primary key")
157 + if (length(child_key) != length(target_key)) {
158 ! add(path, "parent key must match the primary key component count")
159 + } else for (i in seq_along(child_key)) {
160 + child_field <- sheet$fields[[child_key[[i]]]]
161 + parent_field <- target$fields[[target_key[[i]]]]
162 + if (!is.null(child_field) && !is.null(parent_field) &&
163 + !identical(child_field$type, parent_field$type))
164 ! add(path, "parent key components must have the same types as the parent primary key")
165 }
166 }
167 }
168 + for (field_index in seq_along(sheet$fields)) {
169 + field_name <- field_names[[field_index]]
170 + field <- sheet$fields[[field_index]]
171 + field_path <- paste0("$.sheets.", sheet_name, ".fields.", field_name)
172 + constraints <- field
173 + if (!is.null(constraints$minimum) || !is.null(constraints$maximum)) {
174 + if (!field$type %in% c("integer", "number", "latitude", "longitude")) {
175 + add(field_path, "numeric bounds require a numeric field")
176 }
177 + if (!is.null(constraints$minimum) && !is.null(constraints$maximum) &&
178 + constraints$minimum > constraints$maximum) {
179 + add(paste0(field_path, ".minimum"), "minimum exceeds maximum")
180 }
181 + if (field$type == "integer" && any(unlist(constraints[c("minimum", "maximum")]) %% 1 != 0)) {
182 + add(field_path, "integer bounds must be whole numbers")
183 }
184 }
185 + maximum_field <- field$maximum_field
186 + if (!is.null(maximum_field)) {
187 + path <- paste0(field_path, ".maximum_field")
188 + numeric_types <- c("integer", "number", "latitude", "longitude")
189 + if (!field$type %in% numeric_types)
190 ! add(path, "maximum_field requires a numeric field")
191 + if (!maximum_field %in% field_names) {
192 ! add(path, paste0("unknown field: ", maximum_field))
193 + } else if (!sheet$fields[[maximum_field]]$type %in% numeric_types) {
194 ! add(path, "maximum_field must reference a numeric field")
195 }
196 + if (maximum_field == field_name)
197 ! add(path, "field cannot be its own maximum_field")
198 }
199 + if (!is.null(field$sequence)) {
200 + path <- paste0(field_path, ".sequence")
201 + if (!table) add(path, "sequence requires a table layout")
202 + if (!field$type %in% c("integer", "string"))
203 + add(path, "sequence requires an integer or string field")
204 + groups <- unlist(field$sequence$group_by, use.names = FALSE)
205 + if (anyDuplicated(groups)) add(path, "duplicate sequence grouping fields")
206 + for (name in setdiff(groups, field_names))
207 + add(path, paste0("unknown grouping field: ", name))
208 + if (field_name %in% groups) add(path, "sequence cannot group by itself")
209 }
210 + pattern_ok <- TRUE
211 + if (!is.null(constraints$pattern)) {
212 + if (!field$type %in% c("string", "email", "date", "datetime")) {
213 + add(paste0(field_path, ".pattern"), "pattern requires a text or temporal field")
214 }
215 + pattern_ok <- tryCatch({
216 + withCallingHandlers(grepl(constraints$pattern, "", perl = TRUE),
217 + warning = function(w) stop(conditionMessage(w)))
218 + TRUE
219 + }, error = function(e) FALSE)
220 + if (!pattern_ok) add(paste0(field_path, ".pattern"), "invalid PCRE regular expression")
221 }
222 + if (!is.null(constraints$reference) && !is.null(constraints$code_list))
223 ! add(field_path, "use code_list instead of reference")
224 + for (kind in c("reference", "code_list", "registry")) {
225 + use <- constraints[[kind]]
226 + if (is.null(use)) next
227 + id <- if (is.list(use)) use$id else use
228 + path <- paste0(field_path, ".", kind, if (is.list(use)) ".id" else "")
229 + declared <- if (kind == "registry") registries else code_lists
230 + if (!id %in% declared) add(path, paste0("unknown ", kind, ": ", id))
231 + if (!field$type %in% if (kind == "reference") "string" else c("string", "email"))
232 + add(path, if (kind == "reference") "reference constraints require a string field" else
233 + paste0(kind, " constraints require a string or email field"))
234 + if (kind == "registry" && is.list(use) && identical(use$matching, "name") &&
235 + field$type != "string")
236 ! add(path, "registry name matching requires a string field")
237 }
238 + dependency <- field$required_field
239 + if (!is.null(dependency)) {
240 + if (!dependency %in% field_names) {
241 + add(paste0(field_path, ".required_field"), paste0("unknown field: ", dependency))
242 }
243 + if (dependency == field_name) {
244 + add(paste0(field_path, ".required_field"), "field cannot condition its own mandatory value")
245 }
246 }
247 + values <- constraints$enum
248 + labels <- if (length(values)) paste0(field_path, ".enum[", seq_along(values), "]") else character()
249 + for (j in seq_along(values)) {
250 + value <- values[[j]]
251 + if (!form_value_matches_type(value, field$type)) {
252 + add(labels[[j]], paste0("value incompatible with ", field$type))
253 + next
254 }
255 + if (is.numeric(value)) {
256 + if (!is.null(constraints$minimum) && value < constraints$minimum) add(labels[[j]], "value below minimum")
257 + if (!is.null(constraints$maximum) && value > constraints$maximum) add(labels[[j]], "value above maximum")
258 }
259 + if (is.character(value) && !is.null(constraints$pattern) && pattern_ok &&
260 + !grepl(constraints$pattern, value, perl = TRUE)) {
261 + add(labels[[j]], "value does not match pattern")
262 }
263 }
264 + equal <- function(x, y) isTRUE(all.equal(x, y, check.attributes = FALSE))
265 + if (!is.null(constraints$enum)) {
266 + for (j in seq_along(constraints$enum)) {
267 + if (j > 1L && any(vapply(constraints$enum[seq_len(j - 1L)], equal,
268 + logical(1), y = constraints$enum[[j]]))) {
269 + add(paste0(field_path, ".enum[", j, "]"), "duplicate enum value")
270 }
271 }
272 }
273 + if (table && !is.null(field$location)) {
274 + add(paste0(field_path, ".location"), "table fields use their declared order, not fixed locations")
275 }
276 + if (!table && is.null(field$location)) add(paste0(field_path, ".location"), "cell field requires a location")
277 + if (!table && !is.null(field$location)) {
278 + cell <- cell_coordinates(field$location)
279 + if (!is.null(layout$column_count) && cell$column > layout$column_count) add(paste0(field_path, ".location"), "column exceeds sheet extent")
280 + if (!is.null(layout$row_count) && cell$row > layout$row_count) add(paste0(field_path, ".location"), "row exceeds sheet extent")
281 + if (field$location %in% locations) add(paste0(field_path, ".location"), "duplicate workbook location")
282 + locations <- c(locations, field$location)
283 }
284 }
285 }
286 }
287
288 #' Check a form definition
289 #' @param definition Named list following [`form_schema()`][form.model::form_schema]; sequences are unnamed lists.
290 #' @param resource Source label for diagnostics.
291 #' @return A `form_model_check` with `valid` and a `diagnostics` data frame
292 #' containing `resource`, `path` and `message` columns.
293 #' @details Checks schema structure, then model consistency if structure passes.
294 #' Invalid definitions return diagnostics; invalid arguments raise `model_form_error`.
295 #' Submitted data is not checked.
296 #' @examples
297 #' model <- read_form_model("examples/survey-form.yaml", "form.model")
298 #' check_form_model(form_definition(model))
299 #' @export
300 check_form_model <- function(definition, resource = "<list>") {
301 + text_arg(resource, "resource")
302 + diagnostics <- data.frame(resource = character(), path = character(), message = character(), stringsAsFactors = FALSE)
303 # Append one finding with the source label captured by this check.
304 + add <- function(path, message) {
305 + diagnostics[nrow(diagnostics) + 1L, ] <<- list(resource, path, message)
306 + }
307 + schema <- form_schema()
308 + schema_check(definition, schema$definitions[[schema$root]], schema$definitions, "$", add)
309 + if (!nrow(diagnostics)) semantic_check(definition, add)
310 + structure(list(valid = nrow(diagnostics) == 0L, diagnostics = diagnostics), class = "form_model_check")
311 }
312
313 #' Construct a checked model
314 #' @inheritParams check_form_model
315 #' @return The definition as a `form_model` list, without the source label.
316 #' Invalid definitions raise `model_form_error` with diagnostics.
317 #' @examples
318 #' model <- read_form_model("examples/survey-form.yaml", "form.model")
319 #' as_form_model(form_definition(model))
320 #' @export
321 as_form_model <- function(definition, resource = "<list>") {
322 + result <- check_form_model(definition, resource)
323 + if (!result$valid) {
324 + first <- result$diagnostics[1L, ]
325 + abort_model(resource, first$path, first$message, result$diagnostics)
326 }
327 + structure(definition, class = "form_model")
328 }
R/inspect.R
Uncovered lines: 162.
View source
1 #' Check a model argument's shape
2 #' @param model Object passed to an accessor.
3 #' @return Returns silently for a `form_model` with required top-level properties;
4 #' otherwise raises `model_form_error`. Does not recheck the definition.
5 #' @keywords internal
6 model_arg <- function(model) {
7 + required <- c("schema_version", "form", "sheets")
8 + if (!inherits(model, "form_model") || !is.list(model) ||
9 + !all(required %in% names(model)) ||
10 + !"references" %in% names(model)) {
11 + abort_model("<argument>", "model", "expected a form_model; use as_form_model()")
12 }
13 }
14
15 #' Get the complete definition
16 #' @param model A checked `form_model` from [`read_form_model()`][form.model::read_form_model] or [`as_form_model()`][form.model::as_form_model].
17 #' @return An ordinary model definition with `form`, `sheets`, and
18 #' `references` containing declared `code_lists` and `registries`.
19 #' @details Accessors preserve declaration order and do not revalidate models.
20 #' Treat checked models as read-only. Invalid model arguments raise `model_form_error`.
21 #' @examples
22 #' model <- read_form_model("examples/survey-form.yaml", "form.model")
23 #' form_definition(model)$form
24 #' @export
25 form_definition <- function(model) {
26 + model_arg(model)
27 + unclass(model)
28 }
29
30 #' Get form identity and versions
31 #' @inheritParams form_definition
32 #' @return A list with `form` and `schema_version`.
33 #' @examples
34 #' model <- read_form_model("examples/survey-form.yaml", "form.model")
35 #' form_metadata(model)
36 #' @export
37 form_metadata <- function(model) {
38 + d <- form_definition(model)
39 + d[c("form", "schema_version")]
40 }
41
42 #' Get fields in declaration order
43 #' @inheritParams form_definition
44 #' @param sheet Exact worksheet name, or `NULL` for all sheets.
45 #' @return Field definitions named `<sheet>.<field>`. Unknown sheets raise `model_form_error`.
46 #' @details Adds field IDs, names, sheet names and numeric coordinates.
47 #' Omitted `mandatory` becomes `FALSE`; code-list and registry shorthand become
48 #' mappings. Severity defaults to `"error"`; registry matching defaults to `"exact"`.
49 #' Use [`form_definition()`][form.model::form_definition] for the original declarations.
50 #' @examples
51 #' model <- read_form_model("examples/survey-form.yaml", "form.model")
52 #' form_fields(model, sheet = "Observations")
53 #' @export
54 form_fields <- function(model, sheet = NULL) {
55 + sheets <- form_sheets(model)
56 + if (!is.null(sheet)) {
57 + text_arg(sheet, "sheet")
58 + if (!sheet %in% names(sheets)) abort_model("<model>", "sheets", paste0("unknown sheet: ", sheet))
59 + sheets <- sheets[sheet]
60 }
61 + result <- list()
62 + for (sheet_name in names(sheets)) {
63 + definition <- sheets[[sheet_name]]
64 + for (i in seq_along(definition$fields)) {
65 + local_name <- names(definition$fields)[[i]]
66 + field <- definition$fields[[i]]
67 + field$id <- paste(sheet_name, local_name, sep = ".")
68 + field$name <- local_name
69 + field$sheet <- sheet_name
70 + field$mandatory <- isTRUE(field$mandatory)
71 + if (definition$layout$kind == "table") field$column <- i else {
72 + cell <- cell_coordinates(field$location)
73 + field$row <- cell$row
74 + field$column <- cell$column
75 }
76 + for (kind in c("reference", "code_list", "registry")) {
77 + if (is.character(field[[kind]])) field[[kind]] <- list(id = field[[kind]])
78 + if (!is.null(field[[kind]]) && is.null(field[[kind]]$severity))
79 + field[[kind]]$severity <- "error"
80 }
81 + if (!is.null(field$registry) && is.null(field$registry$matching))
82 + field$registry$matching <- "exact"
83 + result[[field$id]] <- field
84 }
85 }
86 + result
87 }
88
89 #' Get one field
90 #' @inheritParams form_definition
91 #' @param id Exact `<sheet>.<field>` identifier.
92 #' @return One definition as returned by [`form_fields()`][form.model::form_fields]. Unknown IDs raise `model_form_error`.
93 #' @examples
94 #' model <- read_form_model("examples/survey-form.yaml", "form.model")
95 #' form_field(model, "Observations.unit")$enum
96 #' @export
97 form_field <- function(model, id) {
98 + text_arg(id, "id")
99 + fields <- form_fields(model)
100 + if (!id %in% names(fields)) abort_model("<model>", "fields", paste0("unknown field: ", id))
101 + fields[[id]]
102 }
103
104 #' Get sheet definitions
105 #' @inheritParams form_definition
106 #' @return Sheets in declaration order, named by worksheet, each with `fields` and `layout`.
107 #' @details Table layouts include `column_count` derived from the ordered fields.
108 #' An optional `primary_key` preserves the declared sequence of local field names.
109 #' Key components must be filled and their combination must identify one row;
110 #' this package checks the declaration, not submitted values.
111 #' Use [`form_definition()`][form.model::form_definition] for the original declarations.
112 #' @examples
113 #' model <- read_form_model("examples/survey-form.yaml", "form.model")
114 #' names(form_sheets(model))
115 #' @export
116 form_sheets <- function(model) {
117 + sheets <- form_definition(model)$sheets
118 + for (name in names(sheets)) {
119 + if (sheets[[name]]$layout$kind == "table") {
120 + sheets[[name]]$layout$column_count <- length(sheets[[name]]$fields)
121 }
122 }
123 + sheets
124 }
125
126 #' Get a sheet layout
127 #' @inheritParams form_definition
128 #' @param id Exact worksheet name.
129 #' @return The effective layout (`cells` or `table`), with table `column_count`
130 #' derived from the fields. Unknown sheets raise `model_form_error`.
131 #' @examples
132 #' model <- read_form_model("examples/survey-form.yaml", "form.model")
133 #' form_layout(model, "Observations")
134 #' @export
135 form_layout <- function(model, id) {
136 + text_arg(id, "id")
137 + sheets <- form_sheets(model)
138 + if (!id %in% names(sheets)) abort_model("<model>", "sheets", paste0("unknown sheet: ", id))
139 + sheets[[id]]$layout
140 }
141
142 #' Get code-list requirements
143 #' @inheritParams form_definition
144 #' @return Declared code-list names. Reference data is not loaded.
145 #' @examples
146 #' model <- read_form_model("examples/survey-form.yaml", "form.model")
147 #' form_code_lists(model)
148 #' @export
149 form_code_lists <- function(model) {
150 + d <- form_definition(model)
151 + refs <- d$references
152 + unlist(if (is.null(names(refs))) refs else refs$code_lists, use.names = FALSE)
153 }
154
155 #' Get registry requirements
156 #' @inheritParams form_definition
157 #' @return Declared registry table names. This does not load registry data.
158 #' @examples
159 #' model <- read_form_model("examples/survey-form.yaml", "form.model")
160 #' form_registries(model)
161 #' @export
162 ! form_registries <- function(model) unlist(form_definition(model)$references$registries, use.names = FALSE)
163
164 #' Print a model summary
165 #' @param x A checked `form_model`.
166 #' @param ... Unused.
167 #' @return `x`, invisibly; prints identity, versions, and field and sheet counts.
168 #' @export
169 print.form_model <- function(x, ...) {
170 + d <- form_definition(x)
171 + cat("<form_model> ", d$form$id, " @ ", d$form$version,
172 + " (schema ", d$schema_version, ")\n", sep = "")
173 + cat(length(form_fields(x)), "fields;", length(d$sheets), "sheets\n")
174 + invisible(x)
175 }
176
177 #' Print definition check results
178 #' @param x A `form_model_check` from [`check_form_model()`][form.model::check_form_model].
179 #' @param ... Unused.
180 #' @return `x`, invisibly; prints validity and any diagnostics.
181 #' @export
182 print.form_model_check <- function(x, ...) {
183 + cat("<form_model_check> ", if (x$valid) "valid" else "invalid", "\n", sep = "")
184 + if (nrow(x$diagnostics)) print(x$diagnostics, row.names = FALSE)
185 + invisible(x)
186 }
187
188 #' Decode a checked cell location
189 #' @param location Uppercase A1-style address already checked by the schema.
190 #' @return List with one-based numeric `row` and `column` coordinates.
191 #' @keywords internal
192 cell_coordinates <- function(location) {
193 + letters <- sub("[0-9]+$", "", location)
194 + list(row = as.numeric(sub("^[A-Z]+", "", location)),
195 + column = Reduce(function(value, digit) value * 26 + digit,
196 + utf8ToInt(letters) - utf8ToInt("A") + 1, init = 0))
197 }
R/read.R
All tracked lines were exercised.
View source
1 #' Check restricted YAML syntax
2 #' @param text YAML source text.
3 #' @param resource Source label for errors.
4 #' @details Rejects tags, anchors, aliases, merges, directives and document markers
5 #' outside quoted strings, comments and block scalars. Parsing happens separately.
6 #' @return Returns silently on success; raises `model_form_error` otherwise.
7 #' @keywords internal
8 yaml_profile <- function(text, resource) {
9 + lines <- strsplit(text, "\n", fixed = TRUE)[[1L]]
10 + quote <- ""
11 + block <- NULL
12 + for (i in seq_along(lines)) {
13 + line <- lines[[i]]
14 + indent <- nchar(line) - nchar(sub("^ *", "", line))
15 + if (!is.null(block)) {
16 + if (!nzchar(trimws(line)) || indent > block) next
17 + block <- NULL
18 }
19 + chars <- strsplit(line, "", fixed = TRUE)[[1L]]
20 + visible <- ""
21 + j <- 1L
22 + while (j <= length(chars)) {
23 + ch <- chars[[j]]
24 + if (nzchar(quote)) {
25 + if (quote == '"' && ch == "\\") {
26 + j <- j + 2L
27 + next
28 + }
29 + if (ch == quote) {
30 + if (quote == "'" && j < length(chars) && chars[[j + 1L]] == "'") {
31 + j <- j + 2L
32 + next
33 + }
34 + quote <- ""
35 + }
36 + visible <- paste0(visible, " ")
37 + } else if (ch %in% c("'", '"') &&
38 + (j == 1L || grepl("[[:space:]:,\\[{?-]$", visible))) {
39 + quote <- ch
40 + visible <- paste0(visible, "Q")
41 + } else {
42 + if (ch == "#" && (j == 1L || grepl("[[:space:]]$", visible))) break
43 + visible <- paste0(visible, ch)
44 + }
45 + j <- j + 1L
46 + }
47 + if (grepl("(^[[:space:]]*([-?][[:space:]]+)?|:[[:space:]]+|[\\[{,][[:space:]]*)[!&*]|(^|[[:space:],{])<<[[:space:]]*:|^%|^---|^\\.\\.\\.", visible)) {
48 + abort_model(resource, paste0("$ (line ", i, ")"),
49 + "YAML tags, anchors, aliases, merges, directives and document markers are unsupported")
50 }
51 + if (grepl("[|>][-+0-9]*[[:space:]]*$", visible)) block <- indent
52 }
53 }
54
55 #' Signal a model error
56 #' @param resource Source label.
57 #' @param path Location within the source.
58 #' @param message Error message.
59 #' @param diagnostics Optional definition diagnostics.
60 #' @return Raises `model_form_error` carrying the supplied context.
61 #' @keywords internal
62 abort_model <- function(resource, path, message, diagnostics = NULL) {
63 + stop(structure(list(message = paste0(resource, ": ", path, ": ", message),
64 + call = NULL, resource = resource, path = path,
65 + diagnostics = diagnostics),
66 + class = c("model_form_error", "error", "condition")))
67 }
68
69 #' Require a nonempty string
70 #' @param x Value to check; whitespace is not trimmed.
71 #' @param name Argument name for errors.
72 #' @return Returns silently on success; raises `model_form_error` otherwise.
73 #' @keywords internal
74 text_arg <- function(x, name) {
75 + if (!is.character(x) || length(x) != 1L || is.na(x) || !nzchar(x)) {
76 + abort_model("<argument>", name, "expected one nonempty string")
77 }
78 }
79
80 #' Read restricted YAML as data
81 #' @param path UTF-8 YAML file.
82 #' @return Parsed data: named lists for mappings and unnamed lists for sequences.
83 #' @details Uses YAML 1.1 types without expression evaluation. Invalid syntax,
84 #' non-string keys and parser warnings raise `model_form_error`.
85 #' @keywords internal
86 read_yaml_data <- function(path) {
87 + text_arg(path, "path")
88 + if (!file.exists(path) || dir.exists(path)) abort_model(path, "$", "file does not exist or is not a regular file")
89 + tryCatch({
90 + text <- paste(readLines(path, warn = FALSE, encoding = "UTF-8"), collapse = "\n")
91 + yaml_profile(text, path)
92 # Keep sequences as lists and check map key types before string conversion.
93 + handler_error <- NULL
94 + handlers <- list(seq = identity, map = function(x) {
95 + keys <- attr(x, "keys")
96 + if (!all(vapply(keys, function(k) is.character(k) && length(k) == 1L && !is.na(k), logical(1)))) {
97 + handler_error <<- "mapping keys must be strings; quote numeric or boolean codes"
98 + return(x)
99 + }
100 + attr(x, "keys") <- NULL
101 + names(x) <- vapply(keys, identity, character(1))
102 + x
103 + })
104 + result <- withCallingHandlers(yaml::yaml.load(text, as.named.list = FALSE,
105 + handlers = handlers, eval.expr = FALSE), warning = function(w) stop(conditionMessage(w)))
106 + if (!is.null(handler_error)) abort_model(path, "$", handler_error)
107 + result
108 + }, error = function(e) {
109 + if (inherits(e, "model_form_error")) stop(e)
110 + abort_model(path, "$", conditionMessage(e))
111 + })
112 }
113
114 #' Locate an installed resource
115 #' @param path File path relative to the package directory.
116 #' @param package Installed package name.
117 #' @return Absolute file path. Missing files and paths escaping the package
118 #' raise `model_form_error`.
119 #' @examples
120 #' form_resource("examples/survey-form.yaml", "form.model")
121 #' @export
122 form_resource <- function(path, package) {
123 + text_arg(path, "path")
124 + text_arg(package, "package")
125 + if (grepl("^[/\\\\~]|^[A-Za-z]:|(^|[/\\\\])\\.\\.([/\\\\]|$)", path)) {
126 + abort_model(package, path, "expected a relative path without parent traversal")
127 }
128 + root <- system.file(package = package)
129 + if (!nzchar(root)) abort_model(package, path, "package is not installed")
130 + root <- normalizePath(root, winslash = "/", mustWork = TRUE)
131 + file <- file.path(root, path)
132 + if (!file.exists(file) || dir.exists(file)) abort_model(package, path, "resource file does not exist")
133 + file <- normalizePath(file, winslash = "/", mustWork = TRUE)
134 + if (!startsWith(file, paste0(root, "/"))) abort_model(package, path, "resource escapes package directory")
135 + file
136 }
137
138 #' Read and check a YAML form model
139 #' @param path File path, or package-relative path when `package` is supplied.
140 #' @param package Optional installed package name.
141 #' @return A checked `form_model` list. Invalid YAML or definitions raise
142 #' `model_form_error` with source context and available diagnostics.
143 #' @details Uses YAML 1.1 types: quote versions and codes; use `true`/`false`
144 #' for booleans. Tags, anchors, aliases, merges, directives and document markers
145 #' are unsupported. The source path is not stored in the model.
146 #' @examples
147 #' model <- read_form_model("examples/survey-form.yaml", "form.model")
148 #' form_metadata(model)
149 #' @export
150 read_form_model <- function(path, package = NULL) {
151 + if (!is.null(package)) path <- form_resource(path, package)
152 + definition <- read_yaml_data(path)
153 + as_form_model(definition, normalizePath(path, winslash = "/", mustWork = TRUE))
154 }
155
156 #' Load a model by filename prefix
157 #' @param name Prefix of `<name>-form.yaml`, starting with a letter and containing
158 #' only letters, digits, underscores, dots or hyphens.
159 #' @param directory Directory containing the file.
160 #' @return A checked `form_model`; see [`read_form_model()`][form.model::read_form_model] for errors.
161 #' @examples
162 #' directory <- system.file("examples", package = "form.model")
163 #' load_form_model("survey", directory)
164 #' @export
165 load_form_model <- function(name, directory) {
166 + text_arg(name, "name")
167 + text_arg(directory, "directory")
168 + if (!grepl("^[A-Za-z][A-Za-z0-9_.-]*$", name)) {
169 + abort_model("<argument>", "name", "expected a model name without a path or file suffix")
170 }
171 + read_form_model(file.path(directory, paste0(name, "-form.yaml")))
172 }
173
174 #' Select an exact model version
175 #' @param paths Nonempty character vector of YAML file paths.
176 #' @param id Exact form identifier.
177 #' @param version Exact form version.
178 #' @param package Optional installed package containing the relative paths.
179 #' @return The matching `form_model`. All files are checked; invalid files or
180 #' anything other than one match raise `model_form_error`.
181 #' @examples
182 #' select_form_model("examples/survey-form.yaml", "survey", "2026.2",
183 #' package = "form.model")
184 #' @export
185 select_form_model <- function(paths, id, version, package = NULL) {
186 + if (!is.character(paths) || !length(paths) || anyNA(paths) || any(!nzchar(paths))) {
187 + abort_model("<selection>", "paths", "expected explicit resource paths")
188 }
189 + text_arg(id, "id")
190 + text_arg(version, "version")
191 + models <- lapply(paths, read_form_model, package = package)
192 + matches <- vapply(models, function(m) {
193 + d <- form_definition(m)
194 + identical(d$form$id, id) && identical(d$form$version, version)
195 + }, logical(1))
196 + if (sum(matches) != 1L) {
197 + abort_model(paste(paths, collapse = ", "), "$",
198 + paste0("exact selection matched ", sum(matches), " resources for ",
199 + id, " / ", version))
200 }
201 + models[[which(matches)]]
202 }
R/values.R
Uncovered lines: 23, 24, 25, 26.
View source
1 #' Check a scalar against a form field type
2 #'
3 #' Share field-type checks between model definitions and validation consumers.
4 #' Requiredness and other field constraints are handled by the caller.
5 #' @param x Scalar value to check, without coercion.
6 #' @param type One of `string`, `email`, `integer`, `number`, `boolean`,
7 #' `latitude`, `longitude`, `date`, or `datetime`.
8 #' @return One logical value; `FALSE` for missing or incompatible values,
9 #' unsupported types, or classed values such as factors, `Date`, and `POSIXct`.
10 #' @details Dates require `YYYY-MM-DD`; datetimes require `YYYY-MM-DDTHH:MM:SSZ`.
11 #' Both must parse and format back to the identical string, using UTC for
12 #' datetimes. Emails require nonempty local and domain parts, a domain dot,
13 #' and no whitespace or additional at signs. Mailbox existence is not checked.
14 #' Numeric values must be finite; integers must have no fractional part.
15 #' Coordinates are decimal degrees: latitude is in `[-90, 90]` and longitude
16 #' in `[-180, 180]`, including both endpoints. Numeric text is not coerced.
17 #' @examples
18 #' form_value_matches_type("contact@example.org", "email")
19 #' form_value_matches_type("2026-10-18T12:00:00Z", "datetime")
20 #' @export
21 form_value_matches_type <- function(x, type) {
22 + if (!scalar_type(type, "string") ||
23 ! !type %in% c("string", "email", "integer", "number", "latitude", "longitude", "boolean", "date", "datetime")) return(FALSE)
24 ! if (type == "latitude") return(scalar_type(x, "number") && x >= -90 && x <= 90)
25 ! if (type == "longitude") return(scalar_type(x, "number") && x >= -180 && x <= 180)
26 ! if (type == "email") return(scalar_type(x, "string") && grepl("^[^\\s@]+@[^\\s@]+\\.[^\\s@]+$", x, perl = TRUE))
27 + if (type %in% c("date", "datetime")) {
28 + if (!scalar_type(x, "string")) return(FALSE)
29 + pattern <- if (type == "date") "^[0-9]{4}-[0-9]{2}-[0-9]{2}$" else
30 + "^[0-9]{4}-[0-9]{2}-[0-9]{2}T[0-9]{2}:[0-9]{2}:[0-9]{2}Z$"
31 + if (!grepl(pattern, x)) return(FALSE)
32 + parsed <- if (type == "date") as.Date(x, format = "%Y-%m-%d") else
33 + as.POSIXct(strptime(x, "%Y-%m-%dT%H:%M:%SZ", tz = "UTC"))
34 + if (is.na(parsed)) return(FALSE)
35 + fmt <- if (type == "date") "%Y-%m-%d" else "%Y-%m-%dT%H:%M:%SZ"
36 + return(identical(format(parsed, fmt, tz = "UTC"), x))
37 }
38 + scalar_type(x, type)
39 }