1################################### 2### generic registry infrastructure 3 4### IDEA: use lexical scope with nested functions to create an 5### S3-"object" that exposes the data structure only through accessor functions. 6 7.FUNCall <- function(f) function(...) f(...) 8 9registry <- 10function(index_field = "names", entry_class = NULL, 11 validity_FUN = NULL, registry_class = NULL, 12 ignore_case = TRUE) 13{ 14### ATTRIBUTES 15 ## repository 16 DATA <- META <- list() 17 18 ## permissions 19 PERMISSIONS <- c(set_entries = TRUE, modify_entries = TRUE, 20 delete_entries = TRUE, set_fields = TRUE) 21 SEALED_FIELDS <- SEALED_ENTRIES <- character(0) 22 23 24### METHODS (PRIVATE) 25 ## helper functions 26 .field_exists <- 27 function(name) 28 name %in% .get_field_names() 29 30 .make_field <- 31 function(default = NA, type = NA, is_mandatory = FALSE, 32 is_modifiable = TRUE, validity_FUN = NULL) 33 structure(list(type = type, 34 default = default, 35 is_mandatory = is_mandatory, 36 is_modifiable = is_modifiable, 37 validity_FUN = validity_FUN), 38 class = "registry_field") 39 40 .make_entry <- function(l) 41 { 42 ## sort 43 l <- l[c(index_field, setdiff(.get_field_names(), index_field))] 44 45 ## return object (possibly inheriting from entry_class) 46 structure(l, class = c(entry_class, "registry_entry")) 47 } 48 49 .get_mandatory_fields <- 50 function() 51 names(META)[sapply(META, function(i) i$is_mandatory)] 52 53 .get_field_defaults <- 54 function() 55 lapply(META, function(i) i$default) 56 57 .get_entry_index <- 58 function(name, stop_if_missing = TRUE) { 59 ## returns the index of the first exact match (modulo case): 60 index <- if (ignore_case) 61 sapply(DATA, 62 function(i) toupper(name) %in% toupper(i[[index_field]])) 63 else 64 sapply(DATA, 65 function(i) name %in% i[[index_field]]) 66 if (!any(index)) { 67 if (stop_if_missing) 68 stop(paste("Entry", dQuote(name), "not in registry.")) 69 else 70 return(NULL) 71 } 72 which(index)[1] 73 } 74 75 .check_value <- 76 function(field_name, field, value) 77 { 78 ## Note we do not check NA entries because this may by set automatically 79 if (!is.function(value) && !any(is.na(value))) { 80 ## check class / list of alternatives, if any 81 if (!any(is.na(field$type))) { 82 ## check list of alternatives 83 if (length(field$type) > 1) { 84 if (!is.character(value) || !value %in% field$type) 85 stop(paste("Possible values for", dQuote(field_name), "are:", 86 paste(field$type, collapse = ", "))) 87 ## check class 88 } else if (!inherits(value, field$type)) { 89 stop(paste("Field", dQuote(field_name), "does not inherit from class", field$type)) 90 } 91 } 92 93 ## apply validity function, if any 94 if (!is.null(field$validity_FUN)) 95 do.call(field$validity_FUN, list(value)) 96 } 97 } 98 99 .check_for_unknown_fields <- 100 function(n) 101 { 102 ## check for fields not in repository 103 missing <- !.field_exists(n) 104 if (any(missing)) 105 stop(paste("Field(s) not in repository:", paste(n[missing], collapse = ", "))) 106 } 107 108### METHODS (PUBLIC) 109 ## field accessors 110 .entry_exists <- 111 function(name) 112 if (ignore_case) 113 toupper(name) %in% toupper(unlist(sapply(DATA, function(i) i[[index_field]]))) 114 else 115 name %in% unlist(sapply(DATA, function(i) i[[index_field]])) 116 117 .get_field <- 118 function(name) 119 { 120 if (!.field_exists(name)) 121 stop(paste("Field", dQuote(name), "not in registry.")) 122 123 META[[name]] 124 } 125 126 .get_fields <- 127 function() 128 META 129 130 .get_field_names <- 131 function() 132 names(META) 133 134 .set_field <- 135 function(name, default = NA, type = NA, is_mandatory = FALSE, 136 is_modifiable = TRUE, validity_FUN = NULL) 137 { 138 ## check permissions 139 if (!PERMISSIONS["set_fields"]) 140 stop("Setting of fields not allowed.") 141 142 ## check for double entries 143 if (.field_exists(name)) 144 stop(paste("Field", dQuote(name), "already in registry.")) 145 146 ## possibly, infer type from argment 147 if (!any(is.na(type)) && !(is.character(type))) 148 type <- class(type) 149 150 ## check mandatory fields 151 if (is_mandatory && !any(is.na(default))) 152 stop("Mandatory fields should have no default.") 153 154 ## create field entry 155 field <- .make_field(type = type, 156 default = default, 157 is_mandatory = is_mandatory, 158 validity_FUN = validity_FUN) 159 160 ## check validity of default 161 .check_value("default", field, default) 162 163 ## add field to meta data 164 META <<- c(META, list(field)) 165 names(META)[length(META)] <<- name 166 167 ## add (missing) fields to data entries 168 DATA <<- lapply(DATA, function(i) {i[[name]] <- default; i}) 169 } 170 171 .n_of_entries <- 172 function() 173 length(DATA) 174 175 ## entry accessors 176 .set_entry <- 177 function(...) 178 { 179 ## check permissions 180 if (!PERMISSIONS["set_entries"]) 181 stop("Setting of entries not allowed.") 182 183 ## parameter handling 184 l <- list(...) 185 n <- names(l) 186 187 .check_for_unknown_fields(n) 188 189 ## check for mandatory fields 190 mandatory_fields <- .get_mandatory_fields() 191 missing_mandatory_fields <- !mandatory_fields %in% n 192 if (any(missing_mandatory_fields)) 193 stop(paste("The following fields are mandatory, but missing:", 194 paste(mandatory_fields[missing_mandatory_fields], collapse = ", "))) 195 196 ## check for double entries 197 for (i in l[[index_field]]) 198 if (.entry_exists(i)) 199 stop(paste("Entry", dQuote(i), "already in registry.")) 200 201 ## check defaults and set values, if needed 202 field_defaults <- .get_field_defaults() 203 default_fields <- names(field_defaults) 204 missing_fields <- setdiff(default_fields, n) 205 l[missing_fields] <- field_defaults[missing_fields] 206 207 ## check field types, and apply field check function, if any. 208 for (f in n) { 209 meta <- .get_field(f) 210 .check_value(f, .get_field(f), l[[f]]) 211 } 212 213 ## apply entry check function 214 if (!is.null(validity_FUN)) 215 do.call(validity_FUN, list(l)) 216 217 ## add entry 218 entry <- .make_entry(l) 219 DATA <<- c(DATA, list(entry)) 220 names(DATA)[length(DATA)] <<- l[[index_field]][1] 221 } 222 223 .get_entries <- 224 function(names = NULL, pattern = NULL) { 225 ## fix search 226 if (!is.null(names)) { 227 if (ignore_case) 228 DATA[intersect(toupper(names), toupper(names(DATA)))] 229 else 230 DATA[intersect(names, names(DATA))] 231 ## grep search 232 } else if (!is.null(pattern)) { 233 pattern_in_entry <- 234 function(x) any(sapply(x, function(i) is.character(i) 235 && length(grep(pattern, i) > 0))) 236 DATA[sapply(DATA, pattern_in_entry)] 237 ## else: return all entries 238 } else DATA 239 240 } 241 242 .get_entry_names <- 243 function() 244 { 245 if (length(DATA) < 1) 246 character(0) 247 else 248 names(DATA) 249 } 250 251 .get_entry <- 252 function(name, stop_if_missing = TRUE) 253 { 254 index <- .get_entry_index(name, stop_if_missing) 255 if (is.null(index)) 256 return(NULL) 257 DATA[[index]] 258 } 259 260 .delete_entry <- 261 function(name) 262 { 263 ## check permissions 264 if (!PERMISSIONS["delete_entries"]) 265 stop("Deletion of entries not allowed.") 266 267 ## fetch entry index (this also checks if the entry exists) 268 entry_index <- .get_entry_index(name) 269 270 ## check sealed entries 271 if (name %in% SEALED_ENTRIES) 272 stop(paste("Deletion of entry", dQuote(name), "not allowed.")) 273 274 ## delete it 275 DATA[entry_index] <<- NULL 276 } 277 278 279 .modify_entry <- 280 function(...) 281 { 282 ## check permissions 283 if (!PERMISSIONS["modify_entries"]) 284 stop("Modifying of entries not allowed.") 285 286 ## parameter handling 287 l <- list(...) 288 n <- names(l) 289 290 ## check for index field 291 if (!index_field %in% n) 292 stop(paste("Index field", dQuote(index_field), "missing.")) 293 294 .check_for_unknown_fields(n) 295 296 ## determine entry name 297 name <- l[[index_field]][1] 298 299 ## fetch entry index (this also checks if the entry exists) 300 entry_index <- .get_entry_index(name) 301 302 ## fetch entry 303 entry <- DATA[[entry_index]] 304 name <- entry[[index_field]][1] 305 306 for (field in setdiff(n, index_field)) { 307 ## check if field is modifiable 308 field_entry <- .get_field(field) 309 if (!field_entry$is_modifiable) 310 stop(paste("Field", dQuote(field), "is not modifiable.")) 311 312 ## check if entry and field are sealed 313 if ((name %in% SEALED_ENTRIES) && (field %in% SEALED_FIELDS)) 314 stop(paste("Modification of field", dQuote(field), 315 "in entry", dQuote(name), "not allowed.")) 316 317 ## check new value 318 value <- l[[field]] 319 .check_value(field, field_entry, value) 320 321 ## modify entry locally 322 entry[[field]] <- value 323 } 324 325 ## apply entry check function 326 if (!is.null(validity_FUN)) 327 do.call(validity_FUN, list(entry)) 328 329 ## modify entry in registry 330 DATA[entry_index] <<- list(entry) 331 } 332 333 ## get all entries for one field 334 .get_field_entries <- 335 function(field, unlist = TRUE) 336 { 337 if (!.field_exists(field)) 338 stop(paste("Field", dQuote(field), "not in registry.")) 339 340 ret <- lapply(DATA, function(i) i[[field]]) 341 if (unlist) 342 unlist(ret) 343 else 344 ret 345 } 346 347 ## permission getters/setters 348 .get_permissions <- 349 function() 350 PERMISSIONS 351 352 .restrict_permissions <- 353 function(set_entries = TRUE, modify_entries = TRUE, 354 delete_entries = TRUE, set_fields = TRUE) 355 { 356 PERMISSIONS["set_entries"] <<- PERMISSIONS["set_entries"] && set_entries 357 PERMISSIONS["modify_entries"] <<- PERMISSIONS["modify_entries"] && modify_entries 358 PERMISSIONS["delete_entries"] <<- PERMISSIONS["delete_entries"] && delete_entries 359 PERMISSIONS["set_fields"] <<- PERMISSIONS["set_fields"] && set_fields 360 } 361 362 .seal_entries <- 363 function() 364 { 365 SEALED_ENTRIES <<- .get_entry_names() 366 SEALED_FIELDS <<- .get_field_names() 367 } 368 369 .get_sealed_entry_names<- 370 function() 371 SEALED_ENTRIES 372 373 .get_sealed_field_names <- 374 function() 375 SEALED_FIELDS 376 377### CONSTRUCTOR 378 379 ## create index field 380 .set_field(name = index_field, type = "character", 381 is_mandatory = TRUE, is_modifiable = FALSE) 382 383 ## return class 384 structure(list(get_field = .FUNCall(.get_field), 385 get_fields = .FUNCall(.get_fields), 386 get_field_names = .FUNCall(.get_field_names), 387 set_field = .FUNCall(.set_field), 388 389 entry_exists = .FUNCall(.entry_exists), 390 get_entry = .FUNCall(.get_entry), 391 get_entries = .FUNCall(.get_entries), 392 get_entry_names = .FUNCall(.get_entry_names), 393 set_entry = .FUNCall(.set_entry), 394 modify_entry = .FUNCall(.modify_entry), 395 delete_entry = .FUNCall(.delete_entry), 396 n_of_entries = .FUNCall(.n_of_entries), 397 398 get_field_entries = .FUNCall(.get_field_entries), 399 400 get_permissions = .FUNCall(.get_permissions), 401 restrict_permissions = .FUNCall(.restrict_permissions), 402 seal_entries = .FUNCall(.seal_entries), 403 get_sealed_entry_names = .FUNCall(.get_sealed_entry_names), 404 get_sealed_field_names = .FUNCall(.get_sealed_field_names) 405 ), 406 class = c(registry_class, "proxy_registry")) 407} 408 409"[[.proxy_registry" <- 410function(x, i) 411 x$get_entry(i) 412 413length.proxy_registry <- 414function(x) 415 x$n_of_entries() 416 417print.proxy_registry <- 418function(x, ...) 419{ 420 l <- x$n_of_entries() 421 if (l < 1) 422 writeLines(paste("An object of class", dQuote("registry"), "with no entry.")) 423 else if (l == 1) 424 writeLines(paste("An object of class", dQuote("registry"), "with one entry.")) 425 else 426 writeLines(paste("An object of class", dQuote("registry"), "with", l, "entries.")) 427} 428 429print.registry_field <- 430function(x, ...) 431 writeLines(formatUL(x, label = names(x), ...)) 432 433print.registry_entry <- 434function(x, ...) 435{ 436 x <- .functions_to_characters(x) 437 x[[1]] <- paste(x[[1]], collapse = ", ") 438 writeLines(formatUL(x, label = names(x))) 439} 440 441summary.proxy_registry <- 442function(object, ...) 443 as.data.frame(object, ...) 444 445as.data.frame.proxy_registry <- 446function(x, ...) 447 do.call(rbind, 448 lapply(x$get_entries(), 449 function(entry) { 450 entry <- .functions_to_characters(entry) 451 data.frame(unclass(entry[-1]), ...) 452 } 453 ) 454 ) 455 456.functions_to_characters <- 457function(x) 458{ 459 ## transform function entries into character strings 460 funs <- sapply(x, inherits, "function") 461 for (field in names(x)[funs]) 462 x[[field]] <- paste(format(x[[field]]), collapse = "") 463 x 464} 465