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
0
fork

Configure Feed

Select the types of activity you want to include in your feed.

Basic implementation completed.

+123 -23
+123 -23
R/big_num.R
··· 67 67 # TODO: validation might be broken? 68 68 if (!node_or_na(self@head)) { 69 69 "@head must be a `node` object or `NA`." 70 - } else if (!node_or_na(self@head)) { 70 + } else if (!node_or_na(self@tail)) { 71 71 "@tail must be a `node` object or `NA`." 72 72 } 73 73 }, constructor = function(num = NULL) { ··· 92 92 } 93 93 ) 94 94 95 + #' Makes a BigNum 96 + #' 97 + #' @param num A character vector representing a number. 98 + #' 99 + #' @return A big_num S7 object. 100 + #' @export 101 + #' 102 + #' @examples 95 103 big_num <- new_class("big_num", 96 104 package = "BigNum", 97 105 properties = list( 98 106 ll = new_property(linked_list, getter = function(self) self@ll) 99 107 ), 100 108 constructor = function(num = "") { 101 - S7::new_object(S7::S7_object(), ll = linked_list(num)) 109 + S7::new_object(S7::S7_object(), ll = linked_list(format(num, trim = TRUE, scientific = FALSE))) 102 110 } 103 111 ) 104 112 105 113 is.na <- new_external_generic("base", "is.na", "x") 106 114 method(is.na, node) <- function(x) !S7_inherits(x, node) 107 115 108 - append <- new_generic("append", "x", function(x, ll, ...) S7_dispatch()) 109 - method(append, node) <- function(x, ll) { 116 + is_even <- new_generic("is_even", c("x")) 117 + method(is_even, big_num) <- function(x) x@ll@head@VALUE %% 2 == 0 118 + 119 + append <- new_generic("append", c("x", "ll")) 120 + method(append, list(node, linked_list)) <- function(x, ll) { 110 121 suppressWarnings( 111 122 if (is.na(ll@head)) { 112 123 ll@head <- x ··· 125 136 126 137 invisible(ll) 127 138 } 128 - method(append, class_numeric) <- function(x, ll) { 139 + method(append, list(class_numeric, linked_list)) <- function(x, ll) { 129 140 stopifnot(x < 10 && x >= 0) 130 141 append(node(x), ll) 142 + } 143 + method(append, list(class_numeric | node, big_num)) <- function(x, ll) { 144 + append(x, ll@ll) 131 145 } 132 146 133 - append_to_start <- new_generic("append_to_start", "x", function(x, ll, ...) S7_dispatch()) 134 - method(append_to_start, node) <- function(x, ll) { 147 + append_to_start <- new_generic("append_to_start", c("x", "ll")) 148 + method(append_to_start, list(node, linked_list)) <- function(x, ll) { 135 149 suppressWarnings( 136 150 if (is.na(ll@head)) { 137 151 ll@head <- x ··· 146 160 147 161 invisible(ll) 148 162 } 149 - method(append_to_start, class_numeric) <- function(x, ll) { 163 + method(append_to_start, list(class_numeric, linked_list)) <- function(x, ll) { 150 164 stopifnot(x < 10 && x >= 0) 151 165 append_to_start(node(x), ll) 166 + } 167 + method(append_to_start, list(class_numeric | node, big_num)) <- function(x, ll) { 168 + append_to_start(x, ll@ll) 152 169 } 153 170 154 171 print <- new_external_generic("base", "print", "x") ··· 162 179 163 180 invisible(x) 164 181 } 165 - 166 182 method(print, big_num) <- function(x) { 167 183 len <- x@ll@length 168 184 ··· 171 187 return(invisible(x)) 172 188 } 173 189 190 + # TODO: remove leading 0s? 174 191 stack <- character(len) 175 192 current <- x@ll@head 176 193 ··· 186 203 } 187 204 188 205 `+` <- new_external_generic("base", "+", c("e1", "e2")) 189 - # TODO: write this 206 + add_helper <- function(node1, node2, carry, sum) { 207 + digit <- node1@VALUE + node2@VALUE + carry 208 + carry <- digit %/% 10 209 + digit <- digit %% 10 210 + append(digit, sum) 211 + 212 + carry 213 + } 190 214 method(`+`, list(big_num, big_num)) <- function(e1, e2) { 191 215 sum <- big_num() 192 - } 216 + node1 <- e1@ll@head 217 + node2 <- e2@ll@head 218 + carry <- 0 193 219 220 + while (!is.na(node1) && !is.na(node2)) { 221 + carry <- add_helper(node1, node2, carry, sum) 222 + node1 <- node1@nxt 223 + node2 <- node2@nxt 224 + } 225 + while (!is.na(node1)) { 226 + carry <- add_helper(node1, node(0), carry, sum) 227 + node1 <- node1@nxt 228 + } 229 + while (!is.na(node2)) { 230 + carry <- add_helper(node2, node(0), carry, sum) 231 + node2 <- node2@nxt 232 + } 233 + if (carry > 0) { 234 + append(carry, sum) 235 + } 236 + 237 + sum 238 + } 194 239 method(`+`, list(big_num, class_numeric)) <- function(e1, e2) { 195 240 e1 + big_num(e2) 196 241 } 197 - 198 242 method(`+`, list(class_numeric, big_num)) <- function(e1, e2) { 199 243 big_num(e1) + e2 200 244 } 201 245 202 - # x <- big_num("") 203 - # x@ll 204 - # len <- x@ll@length 205 - # stack <- character(len) 206 - # current <- x@ll@head 246 + `*` <- new_external_generic("base", "*", c("e1", "e2")) 247 + method(`*`, list(big_num, big_num)) <- function(e1, e2) { 248 + product <- big_num(0) 249 + node2 <- e2@ll@head 250 + shift2 <- 0 251 + while (!is.na(node2)) { 252 + node1 <- e1@ll@head 253 + shift1 <- 0 254 + while (!is.na(node1)) { 255 + temp <- big_num(node1@VALUE * node2@VALUE) 256 + replicate(shift1 + shift2, append_to_start(0, temp)) 257 + product <- product + temp 258 + node1 <- node1@nxt 259 + shift1 <- shift1 + 1 260 + } 261 + node2 <- node2@nxt 262 + shift2 <- shift2 + 1 263 + } 207 264 208 - # for (i in len:1) { 209 - # stack[i] <- current@VALUE 210 - # current <- current@nxt 211 - # } 265 + product 266 + } 267 + method(`*`, list(big_num, class_numeric)) <- function(e1, e2) { 268 + e1 * big_num(e2) 269 + } 270 + method(`*`, list(class_numeric, big_num)) <- function(e1, e2) { 271 + big_num(e1) * e2 272 + } 273 + 274 + `^` <- new_external_generic("base", "^", c("e1", "e2")) 275 + method(`^`, list(big_num, class_numeric)) <- function(e1, e2) { 276 + if (e2 == 0) { 277 + return(big_num(1)) 278 + } else if (e2 == 1) { 279 + return(e1) 280 + } else if (e2 == 2) { 281 + return(e1 * e1) 282 + } else { 283 + if (e2 %% 2 == 1) { 284 + return((e1^2)^(e2 %/% 2)) 285 + } else { 286 + return((e1^2)^(e2 %/% 2) * e1) 287 + } 288 + } 289 + } 212 290 213 - # string <- paste0(stack, collapse = "") 214 - # cat(string) 291 + `==` <- 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) { 295 + return(FALSE) 296 + } 297 + node1 <- e1@ll@head 298 + node2 <- e2@ll@head 299 + for (i in len:1) { 300 + if (node1@VALUE != node2@VALUE) { 301 + return(FALSE) 302 + } 303 + node1 <- node1@nxt 304 + node2 <- node2@nxt 305 + } 306 + TRUE 307 + } 308 + method(`==`, list(big_num, class_numeric)) <- function(e1, e2) { 309 + e1 == big_num(e2) 310 + } 311 + method(`==`, list(class_numeric, big_num)) <- function(e1, e2) { 312 + big_num(e1) == e2 313 + } 314 +