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