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
1node_or_na_s4 <- function(value) is(value, "big_num_node_s4") || is.na(value)
2
3setClass("big_num_node_s4",
4 slots = c(
5 VALUE = "numeric",
6 state = "environment"
7 ),
8 prototype = list(
9 VALUE = NA_real_
10 )
11)
12
13node_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?
20setGeneric("nxt", function(x) standardGeneric("nxt"))
21setMethod("nxt", "big_num_node_s4", function(x) x@state$nxt)
22
23setGeneric("nxt<-", function(x, value) standardGeneric("nxt<-"))
24setMethod("nxt<-", "big_num_node_s4", function(x, value) {
25 x@state$nxt <- value
26 x
27})
28
29setGeneric("VALUE", function(x) standardGeneric("VALUE"))
30setMethod("VALUE", "big_num_node_s4", function(x) x@VALUE)
31
32setGeneric("VALUE<-", function(x, value) standardGeneric("VALUE<-"))
33setMethod("VALUE<-", "big_num_node_s4", function(x, value) {
34 stop("Can't set read-only property VALUE ")
35})
36
37setClass("big_num_linked_list_s4", slots = c(state = "environment"))
38
39linked_list_s4 <- function(num = NULL) {
40 force(num)
41
42 if (is.null(num) || num == "") {
43 return(new("big_num_linked_list_s4", state = rlang::new_environment(list(head = NA, tail = NA, length = 0))))
44 }
45
46 extract_digit_to_node <- function(pos) node_s4(as.integer(substring(num, pos, pos)))
47
48 len <- nchar(num)
49 nodes <- lapply(len:1, function(i) extract_digit_to_node(i))
50
51 if (len != 1) {
52 for (i in (len - 1):1) {
53 nodes[[i]]@state$nxt <- nodes[[i + 1]]
54 }
55 }
56
57 state <- rlang::new_environment(list(
58 head = nodes[[1]],
59 tail = nodes[[len]],
60 length = len
61 ))
62
63 new("big_num_linked_list_s4", state = state)
64}
65
66setClass("big_num_s4", contains = "big_num_linked_list_s4")
67
68big_num_s4 <- function(num = "") {
69 as(linked_list_s4(num), "big_num_s4")
70}
71
72setMethod("show", "big_num_linked_list_s4", function(object) {
73 current <- object@state$head
74 while (is(current, "big_num_node_s4")) {
75 cat(current@VALUE, "-> ")
76 current <- current@state$nxt
77 }
78 cat("NA\n")
79})
80
81setMethod("show", "big_num_s4", function(object) {
82 len <- object@state$length
83
84 if (len == 0) {
85 return(cat("NA\n"))
86 }
87
88 stack <- character(len)
89 current <- object@state$head
90
91 for (i in len:1) {
92 stack[i] <- current@VALUE
93 current <- current@state$nxt
94 }
95
96 string <- paste0(stack, collapse = "")
97 cat(string, "\n")
98})