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
Made strides towards first release
Added a touch of inline documentation.
Started proper roxygen tags for documentation as well.
Added some test cases.
Started readme.
+274
-63
+6
-1
DESCRIPTION
+6
-1
DESCRIPTION
···
1
1
Package: BigNum
2
-
Title: A S7 Showcase
2
+
Title: An S7 Showcase
3
3
Version: 0.0.0.9000
4
4
Authors@R:
5
5
person("Visruth", "Srimath Kandali", , "visruth@gmail.com", role = c("aut", "cre"),
···
14
14
Encoding: UTF-8
15
15
Roxygen: list(markdown = TRUE)
16
16
RoxygenNote: 7.3.2
17
+
Suggests:
18
+
Rmpfr,
19
+
testthat (>= 3.0.0)
20
+
Config/testthat/edition: 3
21
+
Config/testthat/parallel: true
+1
NAMESPACE
+1
NAMESPACE
-4
R/BigNum-package.R
-4
R/BigNum-package.R
+123
-50
R/big_num.R
+123
-50
R/big_num.R
···
1
-
node_or_na <- function(value) is.na(value) || S7_inherits(value, node) # predicate to check if `nd` is a node or NA
1
+
# Start by looking at the `big_num` class
2
+
3
+
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
2
4
3
5
node <- new_class("node",
4
6
package = "BigNum",
5
7
properties = list(
6
8
VALUE = new_property(
7
-
class_numeric, # TODO: make this a generic? Swap to integers here?
9
+
class_numeric, # TODO: make this a generic?
8
10
getter = function(self) self@VALUE
9
11
),
10
12
e = new_property(class_environment, getter = function(self) self@e),
···
20
22
}
21
23
)
22
24
),
23
-
# TODO: fix this validator too
24
25
validator = function(self) {
25
26
if (!node_or_na(self@nxt)) {
26
27
"@nxt must be a `node` object or `NA`."
27
-
}
28
-
if (!is.numeric(self@VALUE) || length(self@VALUE) != 1) {
28
+
} else if (!is.numeric(self@VALUE) || length(self@VALUE) != 1) {
29
29
"@VALUE must be a `numeric` vector of length 1."
30
30
}
31
31
},
32
32
constructor = function(VALUE, nxt = NA) {
33
33
force(VALUE)
34
-
# if (VALUE != floor(VALUE)) warning("Coercing value to integer")
35
-
VALUE <- as.integer(VALUE)
36
34
force(nxt)
37
-
new_object(S7_object(), VALUE = VALUE, e = rlang::env(nxt = nxt))
35
+
36
+
new_object(S7_object(), VALUE = VALUE, e = rlang::new_environment(list(nxt = nxt)))
38
37
}
39
38
)
40
39
···
46
45
getter = function(self) self@e$head,
47
46
setter = function(self, value) {
48
47
# TODO: kick up to error?
49
-
warning("@head should not be set manually", call. = FALSE)
48
+
warning("@head should not be set manually. Maybe you meant to use `append_to_start()`?", call. = FALSE)
49
+
50
+
my_env <- self@e
51
+
my_env$head <- value
50
52
51
-
self@e$head <- value
52
53
self
53
-
}
54
+
},
55
+
validator = node_or_na
54
56
),
55
57
tail = new_property(node,
56
58
getter = function(self) self@e$tail,
57
59
setter = function(self, value) {
58
60
warning("@tail should not be set manually", call. = FALSE)
59
61
60
-
self@e$tail <- value
62
+
my_env <- self@e
63
+
my_env$tail <- value
64
+
61
65
self
62
66
}
63
67
),
64
-
length = new_property(class_numeric, getter = function(self) self@e$length, setter = function(self, value) self@e$length <- value),
65
-
e = new_property(class_environment)
66
-
), validator = function(self) {
67
-
# TODO: validation might be broken?
68
+
length = new_property(class_integer, getter = function(self) self@e$length, setter = function(self, value) {
69
+
warning("@length should not be set manually", call. = FALSE)
70
+
environ <- self@e
71
+
environ$length <- as.integer(value)
72
+
73
+
self
74
+
}),
75
+
e = new_property(class_environment, getter = function(self) self@e)
76
+
),
77
+
validator = function(self) {
68
78
if (!node_or_na(self@head)) {
69
79
"@head must be a `node` object or `NA`."
70
80
} else if (!node_or_na(self@tail)) {
71
81
"@tail must be a `node` object or `NA`."
72
82
}
73
-
}, constructor = function(num = NULL) {
83
+
},
84
+
constructor = function(num = NULL) {
85
+
force(num)
86
+
74
87
if (is.null(num) || num == "") {
75
-
return(new_object(S7_object(), e = rlang::env(head = NA, tail = NA, length = 0)))
88
+
return(new_object(S7_object(), e = rlang::new_environment(list(head = NA, tail = NA, length = 0))))
76
89
}
77
90
78
91
extract_digit_to_node <- function(len) node(as.integer(substring(num, len, len))) # TODO: throw error if the char isn't numeric
···
86
99
}
87
100
}
88
101
89
-
e <- rlang::env(head = nodes[[1]], tail = nodes[[len]], length = len)
102
+
e <- rlang::new_environment(list(
103
+
head = nodes[[1]],
104
+
tail = nodes[[len]],
105
+
length = len
106
+
))
90
107
91
-
S7::new_object(S7::S7_object(), e = e)
108
+
new_object(S7_object(), e = e)
92
109
}
93
110
)
94
111
95
-
#' Makes a BigNum
112
+
#' Infinite precision natural number using a singly linked list
113
+
#'
114
+
#' @description
115
+
#' BigNum exposes three S7 objects, which are all closely related,
116
+
#' i.e. they are all tightly coupled--which isn't great OOP design
117
+
#' but will suffice.
96
118
#'
97
-
#' @param num A character vector representing a number.
119
+
#' The `big_num` class is essentially a wrapper around [linked_list]
120
+
#' with a custom print method as well as some defined operators such as
121
+
#' `+`, `*`, and `^` with an integer.
98
122
#'
99
-
#' @return A big_num S7 object.
100
123
#' @export
101
-
#'
102
-
#' @examples
103
-
big_num <- new_class("big_num",
104
-
package = "BigNum",
124
+
#' @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`
105
128
properties = list(
106
-
ll = new_property(linked_list, getter = function(self) self@ll)
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.
107
130
),
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
+
validator = function(self) {
133
+
# as expected, this predicate just checks if `self`'s `ll` is an actual `linked_list`
134
+
if (!S7_inherits(self@ll, linked_list)) {
135
+
"@ll must be a valid linked list."
136
+
}
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
+
},
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.
108
143
constructor = function(num = "") {
109
-
S7::new_object(S7::S7_object(), ll = linked_list(format(num, trim = TRUE, scientific = FALSE)))
144
+
force(num)
145
+
new_object(S7_object(), ll = linked_list(format(num, trim = TRUE, scientific = FALSE)))
110
146
}
111
147
)
112
148
···
118
154
119
155
append <- new_generic("append", c("x", "ll"))
120
156
method(append, list(node, linked_list)) <- function(x, ll) {
121
-
suppressWarnings(
157
+
suppressWarnings({
122
158
if (is.na(ll@head)) {
123
159
ll@head <- x
124
160
ll@tail <- x
···
126
162
ll@tail@nxt <- x
127
163
ll@tail <- x
128
164
}
129
-
)
130
-
131
-
# TODO: what does this error mean and why does this still work if ignored
132
-
# the attributes do exist in the environment so I'm not using rlang::env properly
133
-
# Error in `@<-.S7_object`:
134
-
# \! Tried to remove non-existent element from pairlist
135
-
try(ll@length <- ll@length + 1, silent = TRUE)
165
+
ll@length <- ll@length + 1
166
+
})
136
167
137
168
invisible(ll)
138
169
}
···
146
177
147
178
append_to_start <- new_generic("append_to_start", c("x", "ll"))
148
179
method(append_to_start, list(node, linked_list)) <- function(x, ll) {
149
-
suppressWarnings(
180
+
suppressWarnings({
150
181
if (is.na(ll@head)) {
151
182
ll@head <- x
152
183
ll@tail <- x
···
154
185
x@nxt <- ll@head
155
186
ll@head <- x
156
187
}
157
-
)
158
-
159
-
try(ll@length <- ll@length + 1, silent = TRUE)
188
+
ll@length <- ll@length + 1
189
+
})
160
190
161
191
invisible(ll)
162
192
}
···
187
217
return(invisible(x))
188
218
}
189
219
190
-
# TODO: remove leading 0s?
191
220
stack <- character(len)
192
221
current <- x@ll@head
193
222
···
197
226
}
198
227
199
228
string <- paste0(stack, collapse = "")
200
-
cat(string)
229
+
cat(string, "\n")
201
230
202
231
invisible(x)
203
232
}
···
243
272
big_num(e1) + e2
244
273
}
245
274
275
+
276
+
# function to remove tail zeros from a `big_num`
277
+
remove_leading_zeros <- function(bn) {
278
+
ll <- bn@ll
279
+
# TODO: length is 1 less than it should be still
280
+
if (ll@length <= 1) {
281
+
return(bn)
282
+
}
283
+
284
+
current <- ll@head
285
+
last_nonzero <- NA
286
+
final_length <- 0
287
+
288
+
while (!is.na(current)) {
289
+
if (current@VALUE != 0) {
290
+
last_nonzero <- current
291
+
final_length <- ll@length
292
+
} else {
293
+
final_length <- final_length - 1
294
+
}
295
+
current <- current@nxt
296
+
}
297
+
298
+
if (is.na(last_nonzero)) {
299
+
suppressWarnings({
300
+
ll@head@nxt <- NA
301
+
ll@tail <- ll@head
302
+
ll@length <- 1
303
+
})
304
+
305
+
return(invisible(bn))
306
+
}
307
+
308
+
last_nonzero@nxt <- NA
309
+
suppressWarnings({
310
+
ll@tail <- last_nonzero
311
+
ll@length <- final_length
312
+
})
313
+
314
+
invisible(bn)
315
+
}
316
+
246
317
`*` <- new_external_generic("base", "*", c("e1", "e2"))
247
318
method(`*`, list(big_num, big_num)) <- function(e1, e2) {
248
319
product <- big_num(0)
···
262
333
shift2 <- shift2 + 1
263
334
}
264
335
265
-
product
336
+
remove_leading_zeros(product)
266
337
}
267
338
method(`*`, list(big_num, class_numeric)) <- function(e1, e2) {
268
339
e1 * big_num(e2)
···
289
360
}
290
361
291
362
`==` <- new_external_generic("base", "==", c("e1", "e2"))
292
-
method(`==`, list(big_num, big_num)) <- function(e1, e2) {
293
-
len <- e1@ll@length
294
-
if (len != e2@ll@length) {
363
+
method(`==`, list(linked_list, linked_list)) <- function(e1, e2) {
364
+
len <- e1@length
365
+
if (len != e2@length) {
295
366
return(FALSE)
296
367
}
297
-
node1 <- e1@ll@head
298
-
node2 <- e2@ll@head
368
+
node1 <- e1@head
369
+
node2 <- e2@head
299
370
for (i in len:1) {
300
371
if (node1@VALUE != node2@VALUE) {
301
372
return(FALSE)
···
305
376
}
306
377
TRUE
307
378
}
379
+
method(`==`, list(big_num, big_num)) <- function(e1, e2) {
380
+
e1@ll == e2@ll
381
+
}
308
382
method(`==`, list(big_num, class_numeric)) <- function(e1, e2) {
309
383
e1 == big_num(e2)
310
384
}
311
385
method(`==`, list(class_numeric, big_num)) <- function(e1, e2) {
312
386
big_num(e1) == e2
313
387
}
314
-
+4
R/zzz.R
+4
R/zzz.R
+51
-7
README.md
+51
-7
README.md
···
1
-
# BigNum
1
+
# BigNum: A showcase and reference for S7
2
+
3
+
Written for `S7 0.2.0.`
4
+
5
+
## Overview
6
+
7
+
***This project is a work in progress, needs reviews and revisions to check for consistency and such. Some best practices for S7 development (e.g. [documentation](https://github.com/RConsortium/S7/issues/315)) haven't been established yet though.***
8
+
9
+
What is S7? What is BigNum? Why can't I subtract two `big_num`s?
10
+
11
+
Let's start with the most interesting part: S7.
12
+
13
+
### S7
14
+
15
+
["The S7 package is a new OOP system designed to be a successor to S3 and S4." - R Consortium Object-Oriented Programming Working Group.](https://rconsortium.github.io/S7/)
2
16
3
-
TODO:
17
+
S7 is a new way to do OOP in R, and it is fantastic. That quote links to the official S7 website, which contains a great deal of information regarding S7--its origins, features, compatibility, specifications, etc. Any developer who wishes to use S7 should certainly study that website. It is quite cogent and detailed, and I use it as a reference all the time–its practically an extra chapter of Advanced R. This package is meant to be used in conjunction with the S7 website, hopefully serving as a (slightly non-contrived) total which can be used to understand how S7 can work in practice. Since S7 is so new, and is still technically experimental, major changes to the API aren't unusual. As such, for this project to be effective, it must be kept in time with S7 as the OOP system matures. Best practice, as and when they are developed, should be implemented to serve as an effective, worked out example for S7 package development.
4
18
5
-
- Finish description
19
+
S7 is in use by a number of people already–some are writing about their experiences as well. One I happened upon is this [blog post](https://blog.djnavarro.net/posts/2024-02-25_s7/) by Dr. Navarro detailing how they used S7 to make some of her latest artwork. Like all of Dr Navarro's posts, it is well worth a read.
6
20
7
-
- Make the BigNum class
21
+
### BigNum
8
22
9
-
- Write tests
23
+
So what is BigNum? And why this project?
24
+
25
+
Firstly, it is important to note that this is a *toy* package. Whilst the package will build, and expose an API one can use to create `big_num` objects, I do not think one *should* use these as infinite precision numbers (for that purpose, look towards packages like [Rmpfr](https://cran.r-project.org/web/packages/Rmpfr/index.html).) This package's implementation is very rough and many properties one would expect from "numbers" are missing–negative numbers, subtraction, division, modulus, etc. are all not implemented. The point of this package is not to veritably implement infinite precision numbers, but rather to show how S7 can be used in a package to make some basic data structures and work with some generics/functions. The package itself is very simple and has a relatively concise and simple implementation. Since this package's purpose is pedagogical, there isn't much point in implementing all the aforementioned features.
26
+
27
+
So why BigNum specifically? Well, mostly because it's easy to implement. The BigNum project is taken from my CSC 203 class, a course in OOP at Cal Poly. As such, I already had all the methods implemented and a clear idea of what I needed to do and how, with the main work being in porting logic to R as opposed to devising the methods and classes needed. This greatly simplified dev time since I had a reference implementation to use. **Importantly,** **this (along with my lack of experience) could lead to unidiomatic R/S7 code and design patterns.** **If you notice anything strange, please open an issue/PR!**
28
+
29
+
I haven't developed an R package before, and so that provided additional motivation for me to create this project. That also means that this package is certainly written sub-optimally. Additionally, my experience with S7 is extremely limited–I would be extremely grateful for any and all R sourcerers who can rain issues and pull requests down from the heavens, fixing all my mistakes :)
30
+
31
+
## References
32
+
33
+
Vaughan D, Hester J, Kalinowski T, Landau W, Lawrence M, Maechler M, Tierney L, Wickham H (2024). *S7: An Object Oriented System Meant to Become a Successor to S3 and S4*. R package version 0.2.0.9000, <https://github.com/RConsortium/S7>, <https://rconsortium.github.io/S7/>.
34
+
35
+
Navarro, Danielle. 2024. “Creating New Generative Art Tools in R with Grid, Ambient, and S7.” February 25, 2024. <https://blog.djnavarro.net/posts/2024-02-25_s7/>.
36
+
37
+
Henry L, Wickham H (2024). *rlang: Functions for Base Types and Core R and 'Tidyverse' Features*. R package version 1.1.4, <https://CRAN.R-project.org/package=rlang>.
38
+
39
+
Maechler M (2024). *Rmpfr: Interface R to MPFR - Multiple Precision Floating-Point Reliable*. R package version 1.0-0, <https://CRAN.R-project.org/package=Rmpfr>.
40
+
41
+
Wickham H (2019). *Advanced R* (2nd ed.). CRC Press.
42
+
43
+
Wickham H, Bryan J (2023). *R Packages* (2nd ed.). O'Reilly Media.
44
+
45
+
## TODOs:
46
+
47
+
- Finish readme
48
+
49
+
- add more citations
10
50
11
51
- Write documentation
12
52
13
-
- Write a vignette
53
+
- Comment code
14
54
15
-
- Comment code
55
+
- Some basic comments for actual use of package
56
+
57
+
- Write tests
58
+
59
+
- Write a vignette?
16
60
17
61
- Website?
+1
-1
man/BigNum-package.Rd
+1
-1
man/BigNum-package.Rd
···
4
4
\name{BigNum-package}
5
5
\alias{BigNum}
6
6
\alias{BigNum-package}
7
-
\title{BigNum: A S7 Showcase}
7
+
\title{BigNum: An S7 Showcase}
8
8
\description{
9
9
A toy package designed to showcase and serve as a reference/tutorial for S7 development. To be used in conjunction with the S7 package website.
10
10
}
+20
man/big_num.Rd
+20
man/big_num.Rd
···
1
+
% Generated by roxygen2: do not edit by hand
2
+
% Please edit documentation in R/big_num.R
3
+
\name{big_num}
4
+
\alias{big_num}
5
+
\title{Infinite precision natural number using a singly linked list}
6
+
\usage{
7
+
big_num(num = "")
8
+
}
9
+
\arguments{
10
+
\item{num}{A string representation of a num.}
11
+
}
12
+
\description{
13
+
BigNum exposes three S7 objects, which are all closely related,
14
+
i.e. they are all tightly coupled--which isn't great OOP design
15
+
but will suffice.
16
+
17
+
The \code{big_num} class is essentially a wrapper around \link{linked_list}
18
+
with a custom print method as well as some defined operators such as
19
+
\code{+}, \code{*}, and \code{^} with an integer.
20
+
}
+12
tests/testthat.R
+12
tests/testthat.R
···
1
+
# This file is part of the standard setup for testthat.
2
+
# It is recommended that you do not modify it.
3
+
#
4
+
# Where should you do additional test configuration?
5
+
# Learn more about the roles of various files in:
6
+
# * https://r-pkgs.org/testing-design.html#sec-tests-files-overview
7
+
# * https://testthat.r-lib.org/articles/special-files.html
8
+
9
+
library(testthat)
10
+
library(BigNum)
11
+
12
+
test_check("BigNum")
+56
tests/testthat/test-big_num.R
+56
tests/testthat/test-big_num.R
···
1
+
rmpfr_test <- function(string_num_1, string_num_2) {
2
+
# using Rmpfr to check big_num's accuracy
3
+
num <- Rmpfr::mpfr(string_num_1, 200) * Rmpfr::mpfr(string_num_2, 200)
4
+
string_num_solution <- as(num, "character")
5
+
6
+
expect_equal(big_num(string_num_1) * big_num(string_num_2), big_num(string_num_solution))
7
+
}
8
+
9
+
test_that("multiplication commutes", {
10
+
expect_equal((big_num(2) * big_num(2)), big_num(4))
11
+
12
+
expect_equal(big_num(2) * big_num(5), big_num(10))
13
+
expect_equal(big_num(5) * big_num(2), big_num(10))
14
+
15
+
expect_equal(big_num(148) * big_num(997), big_num(147556))
16
+
expect_equal(big_num(997) * big_num(148), big_num(147556))
17
+
18
+
rmpfr_test("11111111", "122333444455555")
19
+
rmpfr_test("122333444455555", "11111111")
20
+
})
21
+
22
+
test_that("multiplication big", {
23
+
string_1 <- "321474836474"
24
+
string_2 <- "46548999646551237776"
25
+
string_3 <- "21471047128412996458887978163"
26
+
27
+
rmpfr_test(string_1, string_2)
28
+
rmpfr_test(string_3, string_2)
29
+
})
30
+
31
+
32
+
test_that("multiplication zero", {
33
+
string_1 <- "321474836474"
34
+
string_2 <- "46548999646551237776"
35
+
string_3 <- "21471047128412996458887978163"
36
+
37
+
rmpfr_test(string_1, "0")
38
+
rmpfr_test(string_2, "0")
39
+
rmpfr_test(string_3, "0")
40
+
})
41
+
42
+
43
+
test_that("multiplication one", {
44
+
string_1 <- "321474836474"
45
+
string_2 <- "46548999646551237776"
46
+
string_3 <- "21471047128412996458887978163"
47
+
48
+
rmpfr_test(string_1, "1")
49
+
rmpfr_test(string_2, "1")
50
+
rmpfr_test(string_3, "1")
51
+
})
52
+
53
+
54
+
test_that("exponentiation works", {
55
+
expect_equal(big_num(2)^2, big_num(4))
56
+
})