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
|
R version 3.1.2 (2014-10-31) -- "Pumpkin Helmet"
Copyright (C) 2014 The R Foundation for Statistical Computing
Platform: x86_64-pc-linux-gnu (64-bit)
R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
Type 'license()' or 'licence()' for distribution details.
R is a collaborative project with many contributors.
Type 'contributors()' for more information and
'citation()' on how to cite R or R packages in publications.
Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R.
> ##########################
> ### registry test instances
>
> library(proxy)
Attaching package: 'proxy'
The following objects are masked from 'package:stats':
as.dist, dist
The following object is masked from 'package:base':
as.matrix
>
> .my_check_fun <- function(x) if (x$Z == 999 && x$New2 == 999) stop("No evil allowed!")
>
> ## create registry
> R <- proxy:::registry(entry_class = "simple.list",
+ validity_FUN = .my_check_fun)
> R
An object of class "registry" with no entry.
>
> ## set fields
> R$set_field("X", type = TRUE, is_mandatory = TRUE)
> R$set_field("Y", type = "character")
> R$set_field("Z", default = 123)
> R$get_fields()
$names
type character
default NA
is_mandatory TRUE
is_modifiable TRUE
validity_FUN NULL
$X
type logical
default NA
is_mandatory TRUE
is_modifiable TRUE
validity_FUN NULL
$Y
type character
default NA
is_mandatory FALSE
is_modifiable TRUE
validity_FUN NULL
$Z
type NA
default 123
is_mandatory FALSE
is_modifiable TRUE
validity_FUN NULL
>
> ## add entries
> R$set_entry(names = "test", X = TRUE, Y = "bla")
> R$set_entry(names = "test2", X = FALSE, Y = "foo", Z = 99)
> R$set_entry(names = "test3", X = FALSE, Y = "bar", Z = "chars")
> R$get_entry("test")
_
names test
X TRUE
Y bla
Z 123
> R[["test2"]]
_
names test2
X FALSE
Y foo
Z 99
> R[["test3"]]
_
names test3
X FALSE
Y bar
Z chars
>
> ## add new field
> R$set_field("New")
> R$get_field("New")
type NA
default NA
is_mandatory FALSE
is_modifiable TRUE
validity_FUN NULL
>
> ## change entries
> R$modify_entry(names = "test", New = 123)
> R$modify_entry(names = "test2", New = "test")
>
> ## field check function (checks for strict positive values)
> R$set_field("New2", type = "numeric", validity_FUN = function(x) stopifnot(x > 0))
> R$set_entry(names = "test5", X = TRUE, New2 = 2)
>
> ## add field with fixed alternatives
> R$set_field("New3", type = c("A", "B"))
> R$get_field("New")
type NA
default NA
is_mandatory FALSE
is_modifiable TRUE
validity_FUN NULL
> R$set_entry(names = "test6", X = TRUE, New3 = "A")
>
> ## print/summary = as.data.frame
> R
An object of class "registry" with 5 entries.
> summary(R)
X Y Z New New2 New3
test TRUE bla 123 123 NA <NA>
test2 FALSE foo 99 test NA <NA>
test3 FALSE bar chars <NA> NA <NA>
test5 TRUE <NA> 123 <NA> 2 <NA>
test6 TRUE <NA> 123 <NA> NA A
>
> ## seal entries
> R$seal_entries()
> R$set_field("New4")
> R$set_entry(names = "test7", X = TRUE, Y = "bla")
> R$delete_entry("test7")
> R$modify_entry(names = "test", New4 = "test")
>
> ## error cases:
> TRY <- function(...) stopifnot(inherits(try(..., silent = TRUE), "try-error"))
> TRY(R$set_field("bla", type = "character", default = 123))
> TRY(R$set_entry("err1", Y = "bla"))
> TRY(R$set_entry("err2", X = "bla"))
> TRY(R$set_entry("err3", X = TRUE, New2 = -2))
> TRY(R$set_entry("err4", X = TRUE, Z = 999, New2 = 999))
> TRY(R$set_entry("err5", X = TRUE, New3 = "C"))
> TRY(R$modify_entry("Bla", "New", 123))
> TRY(R$modify_entry("X", "Bla", 123))
> TRY(R$modify_entry("test","X",TRUE))
>
> proc.time()
user system elapsed
0.226 0.011 0.230
|