A toy package designed to showcase and serve as a reference/tutorial for S7 development. To be used in conjunction with the S7 package webs
Started work on S3 and S4 implementations of BigNum
+230
-39
+2
-1
DESCRIPTION
+2
-1
DESCRIPTION
+1
NAMESPACE
+1
NAMESPACE
+1
R/BigNum-package.R
+1
R/BigNum-package.R
+73
-38
R/big_num.R
+73
-38
R/big_num.R
···
1
-
# Start by looking at the `big_num` class
2
-
3
1
node_or_na <- function(value) is.na(value) || S7_inherits(value, node) # predicate to check if `value` is a `node` or `NA`, pulled out to reduce duplication
4
2
5
3
node <- new_class("node",
···
7
5
properties = list(
8
6
VALUE = new_property(
9
7
class_numeric, # TODO: make this a generic?
10
-
getter = function(self) self@VALUE
8
+
getter = function(self) self@VALUE,
9
+
setter = NULL
11
10
),
12
-
e = new_property(class_environment, getter = function(self) self@e),
11
+
state = new_property(
12
+
class_environment,
13
+
getter = function(self) self@state,
14
+
setter = NULL
15
+
),
13
16
nxt = new_property(class_any,
14
17
getter = function(self) {
15
-
self@e$nxt
18
+
self@state$nxt
16
19
},
17
20
setter = function(self, value) {
18
-
my_env <- self@e
21
+
my_env <- self@state
19
22
my_env$nxt <- value
20
23
21
24
self
···
33
36
force(VALUE)
34
37
force(nxt)
35
38
36
-
new_object(S7_object(), VALUE = VALUE, e = rlang::new_environment(list(nxt = nxt)))
39
+
new_object(S7_object(), VALUE = VALUE, state = rlang::new_environment(list(nxt = nxt)))
37
40
}
38
41
)
39
42
···
42
45
properties = list(
43
46
head = new_property(
44
47
node,
45
-
getter = function(self) self@e$head,
48
+
getter = function(self) self@state$head,
46
49
setter = function(self, value) {
47
50
# TODO: kick up to error?
48
51
warning("@head should not be set manually. Maybe you meant to use `append_to_start()`?", call. = FALSE)
49
52
50
-
my_env <- self@e
53
+
my_env <- self@state
51
54
my_env$head <- value
52
55
53
56
self
···
55
58
validator = node_or_na
56
59
),
57
60
tail = new_property(node,
58
-
getter = function(self) self@e$tail,
61
+
getter = function(self) self@state$tail,
59
62
setter = function(self, value) {
60
63
warning("@tail should not be set manually", call. = FALSE)
61
64
62
-
my_env <- self@e
65
+
my_env <- self@state
63
66
my_env$tail <- value
64
67
65
68
self
66
69
}
67
70
),
68
-
length = new_property(class_integer, getter = function(self) self@e$length, setter = function(self, value) {
71
+
length = new_property(class_integer, getter = function(self) self@state$length, setter = function(self, value) {
69
72
warning("@length should not be set manually", call. = FALSE)
70
-
environ <- self@e
73
+
environ <- self@state
71
74
environ$length <- as.integer(value)
72
75
73
76
self
74
77
}),
75
-
e = new_property(class_environment, getter = function(self) self@e)
78
+
state = new_property(class_environment, getter = function(self) self@state)
76
79
),
77
80
validator = function(self) {
78
81
if (!node_or_na(self@head)) {
···
85
88
force(num)
86
89
87
90
if (is.null(num) || num == "") {
88
-
return(new_object(S7_object(), e = rlang::new_environment(list(head = NA, tail = NA, length = 0))))
91
+
return(new_object(S7_object(), state = rlang::new_environment(list(head = NA, tail = NA, length = 0))))
89
92
}
90
93
91
-
extract_digit_to_node <- function(len) node(as.integer(substring(num, len, len))) # TODO: throw error if the char isn't numeric
94
+
extract_digit_to_node <- function(pos) node(as.integer(substring(num, pos, pos))) # TODO: throw error if the char isn't numeric
92
95
93
96
len <- nchar(num)
94
97
nodes <- lapply(len:1, function(i) extract_digit_to_node(i))
···
99
102
}
100
103
}
101
104
102
-
e <- rlang::new_environment(list(
105
+
state <- rlang::new_environment(list(
103
106
head = nodes[[1]],
104
107
tail = nodes[[len]],
105
108
length = len
106
109
))
107
110
108
-
new_object(S7_object(), e = e)
111
+
new_object(S7_object(), state = state)
109
112
}
110
113
)
111
114
···
122
125
#'
123
126
#' @export
124
127
#' @param num A string representation of a num.
125
-
big_num <- new_class("big_num", # this defines the class, and should match the name of the object on the left-hand-side of the assignment.
126
-
package = "BigNum", # this defines a package for this `big_num` object so that it doesn't conflict with other potential `big_num` objects from other packages.
127
-
# properties defines a list of variables that `big_num`s have. Here we have just one property, a `linked_list`
128
+
big_num <- new_class("big_num",
129
+
package = "BigNum",
128
130
properties = list(
129
-
ll = new_property(linked_list, getter = function(self) self@ll) # this property has a custom getter, but no setter. This means that you can get a `big_num`'s `ll` but you cannot set it--i.e. this is a read-only property.
131
+
ll = new_property(
132
+
linked_list,
133
+
getter = function(self) self@ll,
134
+
setter = NULL
135
+
)
130
136
),
131
-
# the class validator is a function that takes a purported `big_num` object (viz. `self`), and runs some checks to ensure that it actually is a `big_num`.
132
137
validator = function(self) {
133
-
# as expected, this predicate just checks if `self`'s `ll` is an actual `linked_list`
134
138
if (!S7_inherits(self@ll, linked_list)) {
135
139
"@ll must be a valid linked list."
136
140
}
137
-
# all validators should return a string if there is an error, or NULL if all's good. Let R return NULL for you automatically.
138
141
},
139
-
# S7 objects can have custom constructors which allow you to do some logic with inputs before ending with a call to `new_object()`
140
-
# this constructor finesses the input to allow for construction of `big_num`s with a numeric `num` as well as the expected character input
141
-
# note as well that the constructor is a function, and so it takes certain arguments which can have default values. Here, all `big_nums` start
142
-
# out empty. However, looking at the `node` class one can note that `val` has no default and so must be provided when creating a `node` object.
143
142
constructor = function(num = "") {
144
143
force(num)
145
-
new_object(S7_object(), ll = linked_list(format(num, trim = TRUE, scientific = FALSE)))
144
+
145
+
if (!is.character(num)) warning("Coercing `num` to string using `format()`")
146
+
147
+
num <- format(num, trim = TRUE, scientific = FALSE) # TODO: test this
148
+
new_object(S7_object(), ll = linked_list(num))
146
149
}
147
150
)
148
151
152
+
# TODO: Rewrite to inherit from linked_list--adjust methods accordingly
153
+
# big_num <- new_class("big_num",
154
+
# parent = linked_list,
155
+
# package = "BigNum",
156
+
# constructor = function(num = "") {
157
+
# new_object(linked_list(), num = num)
158
+
# }
159
+
# )
160
+
149
161
is.na <- new_external_generic("base", "is.na", "x")
150
162
method(is.na, node) <- function(x) !S7_inherits(x, node)
151
163
152
164
is_even <- new_generic("is_even", c("x"))
153
165
method(is_even, big_num) <- function(x) x@ll@head@VALUE %% 2 == 0
154
166
155
-
append <- new_generic("append", c("x", "ll"))
156
-
method(append, list(node, linked_list)) <- function(x, ll) {
167
+
# TODO: rewrite to be external generic?
168
+
bn_append <- new_generic("bn_append", c("x", "ll"))
169
+
method(bn_append, list(node, linked_list)) <- function(x, ll) {
157
170
suppressWarnings({
158
171
if (is.na(ll@head)) {
159
172
ll@head <- x
···
167
180
168
181
invisible(ll)
169
182
}
170
-
method(append, list(class_numeric, linked_list)) <- function(x, ll) {
183
+
method(bn_append, list(class_numeric, linked_list)) <- function(x, ll) {
171
184
stopifnot(x < 10 && x >= 0)
172
-
append(node(x), ll)
185
+
bn_append(node(x), ll)
173
186
}
174
-
method(append, list(class_numeric | node, big_num)) <- function(x, ll) {
175
-
append(x, ll@ll)
187
+
method(bn_append, list(class_numeric | node, big_num)) <- function(x, ll) {
188
+
bn_append(x, ll@ll)
176
189
}
177
190
178
191
append_to_start <- new_generic("append_to_start", c("x", "ll"))
···
231
244
invisible(x)
232
245
}
233
246
247
+
# method(print, big_num) <- function(x) {
248
+
# len <- x@length
249
+
250
+
# if (len == 0) {
251
+
# cat("NA\n")
252
+
# return(invisible(x))
253
+
# }
254
+
255
+
# stack <- character(len)
256
+
# current <- x@head
257
+
258
+
# for (i in len:1) {
259
+
# stack[i] <- current@VALUE
260
+
# current <- current@nxt
261
+
# }
262
+
263
+
# string <- paste0(stack, collapse = "")
264
+
# cat(string, "\n")
265
+
266
+
# invisible(x)
267
+
# }
268
+
234
269
`+` <- new_external_generic("base", "+", c("e1", "e2"))
235
270
add_helper <- function(node1, node2, carry, sum) {
236
271
digit <- node1@VALUE + node2@VALUE + carry
237
272
carry <- digit %/% 10
238
273
digit <- digit %% 10
239
-
append(digit, sum)
274
+
bn_append(digit, sum)
240
275
241
276
carry
242
277
}
···
260
295
node2 <- node2@nxt
261
296
}
262
297
if (carry > 0) {
263
-
append(carry, sum)
298
+
bn_append(carry, sum)
264
299
}
265
300
266
301
sum
+79
R/big_num_S3.R
+79
R/big_num_S3.R
···
1
+
node_or_na_s3 <- function(value) is.na(value) || inherits(value, "big_num_node_s3")
2
+
3
+
node_s3 <- function(VALUE, nxt = NA) {
4
+
stopifnot(node_or_na_s3(nxt), is.numeric(VALUE), length(VALUE) == 1)
5
+
6
+
structure(
7
+
list(
8
+
VALUE = VALUE,
9
+
state = rlang::new_environment(list(nxt = nxt))
10
+
),
11
+
class = "big_num_node_s3"
12
+
)
13
+
}
14
+
15
+
linked_list_s3 <- function(num = NULL) {
16
+
force(num)
17
+
18
+
if (is.null(num) || num == "") {
19
+
return(structure(list(state = rlang::new_environment(list(head = NA, tail = NA, length = 0))), class = "big_num_linked_list_s3"))
20
+
}
21
+
22
+
extract_digit_to_node <- function(pos) node_s3(as.integer(substring(num, pos, pos))) # TODO: throw error if the char isn't numeric
23
+
24
+
len <- nchar(num)
25
+
nodes <- lapply(len:1, function(i) extract_digit_to_node(i))
26
+
27
+
if (len != 1) {
28
+
for (i in (len - 1):1) {
29
+
nodes[[i]]$state$nxt <- nodes[[i + 1]]
30
+
}
31
+
}
32
+
33
+
state <- rlang::new_environment(list(
34
+
head = nodes[[1]],
35
+
tail = nodes[[len]],
36
+
length = len
37
+
))
38
+
39
+
structure(
40
+
list(
41
+
state = state
42
+
),
43
+
class = "big_num_linked_list_s3"
44
+
)
45
+
}
46
+
47
+
big_num_s3 <- function(num = "") {
48
+
structure(linked_list_s3(num), class = "big_num_s3")
49
+
}
50
+
51
+
is.na.node_s3 <- function(x) {
52
+
!inherits(x, "big_num_node_s3")
53
+
}
54
+
55
+
is_even_s3 <- function(x) {
56
+
UseMethod("is_even_s3")
57
+
}
58
+
59
+
is_even_s3.big_num <- function(x) {
60
+
x$ll$state$head$VALUE %% 2 == 0
61
+
}
62
+
63
+
bn_append_s3 <- function(x, ll) {
64
+
UseMethod("bn_append_s3")
65
+
}
66
+
67
+
# TODO: fix this later
68
+
bn_append_s3.linked_list <- function(x, ll) {
69
+
if (is.na(ll$state$head)) {
70
+
ll$state$head <- x
71
+
ll$state$tail <- x
72
+
} else {
73
+
ll$state$tail@nxt <- x
74
+
ll$state$tail <- x
75
+
}
76
+
ll@length <- ll@length + 1
77
+
78
+
invisible(ll)
79
+
}
+74
R/big_num_S4.R
+74
R/big_num_S4.R
···
1
+
node_or_na_s4 <- function(value) is.na(value) || is(value, "big_num_node_s4")
2
+
3
+
setClass("big_num_node_s4",
4
+
slots = c(
5
+
VALUE = "numeric",
6
+
state = "environment"
7
+
),
8
+
prototype = list(
9
+
VALUE = NA_real_
10
+
)
11
+
)
12
+
13
+
node_s4 <- function(VALUE, nxt = NA) {
14
+
stopifnot(node_or_na_s4(nxt), is.numeric(VALUE), length(VALUE) == 1)
15
+
16
+
new("big_num_node_s4", VALUE = VALUE, state = rlang::new_environment(list(nxt = nxt)))
17
+
}
18
+
19
+
# TODO: copy this in S3 to approximate read only properties
20
+
setGeneric("nxt", function(x) standardGeneric("nxt"))
21
+
setMethod("nxt", "big_num_node_s4", function(x) x@state$nxt)
22
+
23
+
setGeneric("nxt<-", function(x, value) standardGeneric("nxt<-"))
24
+
setMethod("nxt<-", "big_num_node_s4", function(x, value) {
25
+
x@state$nxt <- value
26
+
x
27
+
})
28
+
29
+
setGeneric("VALUE", function(x) standardGeneric("VALUE"))
30
+
setMethod("VALUE", "big_num_node_s4", function(x) x@VALUE)
31
+
32
+
setGeneric("VALUE<-", function(x, value) standardGeneric("VALUE<-"))
33
+
setMethod("VALUE<-", "big_num_node_s4", function(x, value) {
34
+
stop("Can't set read-only property VALUE ")
35
+
})
36
+
37
+
setClass("big_num_linked_list_s4",
38
+
slots = c(
39
+
state = "environment"
40
+
)
41
+
)
42
+
43
+
linked_list_s4 <- function(num = NULL) {
44
+
force(num)
45
+
46
+
if (is.null(num) || num == "") {
47
+
return(new("big_num_linked_list_s4", state = rlang::new_environment(list(head = NA, tail = NA, length = 0))))
48
+
}
49
+
50
+
extract_digit_to_node <- function(pos) node_s4(as.integer(substring(num, pos, pos)))
51
+
52
+
len <- nchar(num)
53
+
nodes <- lapply(len:1, function(i) extract_digit_to_node(i))
54
+
55
+
if (len != 1) {
56
+
for (i in (len - 1):1) {
57
+
nodes[[i]]@state$nxt <- nodes[[i + 1]]
58
+
}
59
+
}
60
+
61
+
state <- rlang::new_environment(list(
62
+
head = nodes[[1]],
63
+
tail = nodes[[len]],
64
+
length = len
65
+
))
66
+
67
+
new("big_num_linked_list_s4", state = state)
68
+
}
69
+
70
+
setClass("big_num_s4", contains = "big_num_linked_list_s4")
71
+
72
+
big_num_s4 <- function(num = "") {
73
+
as(linked_list_s4(num), "big_num_s4")
74
+
}