Basic implementations of BigNum in S3/4/7. · visruth.com/BigNum@9e3c3de

+9

NAMESPACE

··· 1 1 # Generated by roxygen2: do not edit by hand 2 2 3 + S3method(base::print,big_num_linked_list_s3) 4 + S3method(base::print,big_num_s3) 5 + S3method(bn_append_s3,big_num_node_s3) 6 + S3method(is_even_s3,big_num_s3) 3 7 export(big_num) 8 + export(big_num_s3) 9 + export(bn_append_s3) 10 + export(is_even_s3) 11 + export(linked_list_s3) 12 + export(node_s3) 4 13 if (getRversion() < "4.3.0") importFrom("S7", "@") 5 14 import(S7) 6 15 import(methods)

+33 -92

R/big_num.R

··· 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 1 + # TODO: pull out latter part of statement and rewrite as `is_node(x)` 2 + node_or_na <- function(value) S7_inherits(value, node) || is.na(value) # predicate to check if `value` is a `node` or `NA`, pulled out to reduce duplication 2 3 3 4 node <- new_class("node", 4 5 package = "BigNum", ··· 115 116 #' Infinite precision natural number using a singly linked list 116 117 #' 117 118 #' @description 118 - #' BigNum exposes three S7 objects, which are all closely related, 119 - #' i.e. they are all tightly coupled--which isn't great OOP design 120 - #' but will suffice. 119 + #' TODO: WRITE THIS 121 120 #' 122 121 #' The `big_num` class is essentially a wrapper around [linked_list] 123 122 #' with a custom print method as well as some defined operators such as ··· 126 125 #' @export 127 126 #' @param num A string representation of a num. 128 127 big_num <- new_class("big_num", 128 + parent = linked_list, 129 129 package = "BigNum", 130 - properties = list( 131 - ll = new_property( 132 - linked_list, 133 - getter = function(self) self@ll, 134 - setter = NULL 135 - ) 136 - ), 137 - validator = function(self) { 138 - if (!S7_inherits(self@ll, linked_list)) { 139 - "@ll must be a valid linked list." 140 - } 141 - }, 142 130 constructor = function(num = "") { 143 - force(num) 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)) 131 + new_object(linked_list(num)) 149 132 } 150 133 ) 151 134 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 - 161 - is.na <- new_external_generic("base", "is.na", "x") 162 - method(is.na, node) <- function(x) !S7_inherits(x, node) 135 + # is.na <- new_external_generic("base", "is.na", "x") 136 + # method(is.na, node) <- function(x) !S7_inherits(x, node) 163 137 164 138 is_even <- new_generic("is_even", c("x")) 165 - method(is_even, big_num) <- function(x) x@ll@head@VALUE %% 2 == 0 139 + method(is_even, big_num) <- function(x) x@head@VALUE %% 2 == 0 166 140 167 141 # TODO: rewrite to be external generic? 168 142 bn_append <- new_generic("bn_append", c("x", "ll")) 169 143 method(bn_append, list(node, linked_list)) <- function(x, ll) { 170 144 suppressWarnings({ 171 - if (is.na(ll@head)) { 145 + if (!S7_inherits(ll@head)) { 172 146 ll@head <- x 173 147 ll@tail <- x 174 148 } else { ··· 184 158 stopifnot(x < 10 && x >= 0) 185 159 bn_append(node(x), ll) 186 160 } 187 - method(bn_append, list(class_numeric | node, big_num)) <- function(x, ll) { 188 - bn_append(x, ll@ll) 189 - } 190 161 191 162 append_to_start <- new_generic("append_to_start", c("x", "ll")) 192 163 method(append_to_start, list(node, linked_list)) <- function(x, ll) { 193 164 suppressWarnings({ 194 - if (is.na(ll@head)) { 165 + if (!S7_inherits(ll@head)) { 195 166 ll@head <- x 196 167 ll@tail <- x 197 168 } else { ··· 206 177 method(append_to_start, list(class_numeric, linked_list)) <- function(x, ll) { 207 178 stopifnot(x < 10 && x >= 0) 208 179 append_to_start(node(x), ll) 209 - } 210 - method(append_to_start, list(class_numeric | node, big_num)) <- function(x, ll) { 211 - append_to_start(x, ll@ll) 212 180 } 213 181 214 182 print <- new_external_generic("base", "print", "x") 215 183 method(print, linked_list) <- function(x) { 216 184 current <- x@head 217 - while (!is.na(current)) { 185 + while (S7_inherits(current)) { 218 186 cat(current@VALUE, "-> ") 219 187 current <- current@nxt 220 188 } ··· 223 191 invisible(x) 224 192 } 225 193 method(print, big_num) <- function(x) { 226 - len <- x@ll@length 194 + len <- x@length 227 195 228 196 if (len == 0) { 229 197 cat("NA\n") ··· 231 199 } 232 200 233 201 stack <- character(len) 234 - current <- x@ll@head 202 + current <- x@head 235 203 236 204 for (i in len:1) { 237 205 stack[i] <- current@VALUE ··· 244 212 invisible(x) 245 213 } 246 214 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 - 269 215 `+` <- new_external_generic("base", "+", c("e1", "e2")) 270 216 add_helper <- function(node1, node2, carry, sum) { 271 217 digit <- node1@VALUE + node2@VALUE + carry ··· 277 223 } 278 224 method(`+`, list(big_num, big_num)) <- function(e1, e2) { 279 225 sum <- big_num() 280 - node1 <- e1@ll@head 281 - node2 <- e2@ll@head 226 + node1 <- e1@head 227 + node2 <- e2@head 282 228 carry <- 0 283 229 284 - while (!is.na(node1) && !is.na(node2)) { 230 + while (S7_inherits(node1) && S7_inherits(node2)) { 285 231 carry <- add_helper(node1, node2, carry, sum) 286 232 node1 <- node1@nxt 287 233 node2 <- node2@nxt 288 234 } 289 - while (!is.na(node1)) { 235 + while (S7_inherits(node1)) { 290 236 carry <- add_helper(node1, node(0), carry, sum) 291 237 node1 <- node1@nxt 292 238 } 293 - while (!is.na(node2)) { 239 + while (S7_inherits(node2)) { 294 240 carry <- add_helper(node2, node(0), carry, sum) 295 241 node2 <- node2@nxt 296 242 } ··· 307 253 big_num(e1) + e2 308 254 } 309 255 310 - 311 256 # function to remove tail zeros from a `big_num` 312 257 remove_leading_zeros <- function(bn) { 313 - ll <- bn@ll 314 - # TODO: length is 1 less than it should be still 315 - if (ll@length <= 1) { 258 + if (bn@length <= 1) { 316 259 return(bn) 317 260 } 318 261 319 - current <- ll@head 262 + current <- bn@head 320 263 last_nonzero <- NA 321 264 final_length <- 0 322 265 323 - while (!is.na(current)) { 266 + while (S7_inherits(current)) { 324 267 if (current@VALUE != 0) { 325 268 last_nonzero <- current 326 - final_length <- ll@length 269 + final_length <- bn@length 327 270 } else { 328 271 final_length <- final_length - 1 329 272 } 330 273 current <- current@nxt 331 274 } 332 275 333 - if (is.na(last_nonzero)) { 276 + if (!S7_inherits(last_nonzero)) { 334 277 suppressWarnings({ 335 - ll@head@nxt <- NA 336 - ll@tail <- ll@head 337 - ll@length <- 1 278 + bn@head@nxt <- NA 279 + bn@tail <- bn@head 280 + bn@length <- 1 338 281 }) 339 282 340 283 return(invisible(bn)) ··· 342 285 343 286 last_nonzero@nxt <- NA 344 287 suppressWarnings({ 345 - ll@tail <- last_nonzero 346 - ll@length <- final_length 288 + bn@tail <- last_nonzero 289 + bn@length <- final_length 347 290 }) 348 291 349 292 invisible(bn) ··· 352 295 `*` <- new_external_generic("base", "*", c("e1", "e2")) 353 296 method(`*`, list(big_num, big_num)) <- function(e1, e2) { 354 297 product <- big_num(0) 355 - node2 <- e2@ll@head 298 + node2 <- e2@head 356 299 shift2 <- 0 357 - while (!is.na(node2)) { 358 - node1 <- e1@ll@head 300 + while (S7_inherits(node2)) { 301 + node1 <- e1@head 359 302 shift1 <- 0 360 - while (!is.na(node1)) { 303 + while (S7_inherits(node1)) { 361 304 temp <- big_num(node1@VALUE * node2@VALUE) 362 305 replicate(shift1 + shift2, append_to_start(0, temp)) 363 306 product <- product + temp ··· 411 354 } 412 355 TRUE 413 356 } 414 - method(`==`, list(big_num, big_num)) <- function(e1, e2) { 415 - e1@ll == e2@ll 416 - } 357 + 417 358 method(`==`, list(big_num, class_numeric)) <- function(e1, e2) { 418 359 e1 == big_num(e2) 419 360 }

+50 -12

R/big_num_S3.R

··· 1 - node_or_na_s3 <- function(value) is.na(value) || inherits(value, "big_num_node_s3") 1 + node_or_na_s3 <- function(value) inherits(value, "big_num_node_s3") || all(is.na(value)) 2 2 3 + #' @export 3 4 node_s3 <- function(VALUE, nxt = NA) { 4 5 stopifnot(node_or_na_s3(nxt), is.numeric(VALUE), length(VALUE) == 1) 5 6 ··· 12 13 ) 13 14 } 14 15 16 + #' @export 15 17 linked_list_s3 <- function(num = NULL) { 16 18 force(num) 17 19 ··· 44 46 ) 45 47 } 46 48 49 + #' @export 47 50 big_num_s3 <- function(num = "") { 48 - structure(linked_list_s3(num), class = "big_num_s3") 51 + structure(linked_list_s3(num), class = c("big_num_s3", "big_num_linked_list_s3")) 49 52 } 50 53 51 - is.na.node_s3 <- function(x) { 52 - !inherits(x, "big_num_node_s3") 53 - } 54 + # is.na.node_s3 <- function(x) { 55 + # \!inherits(x, "big_num_node_s3") 56 + # } 54 57 58 + #' @export 55 59 is_even_s3 <- function(x) { 56 60 UseMethod("is_even_s3") 57 61 } 58 - 59 - is_even_s3.big_num <- function(x) { 60 - x$ll$state$head$VALUE %% 2 == 0 62 + #' @export 63 + is_even_s3.big_num_s3 <- function(x) { 64 + x$state$head$VALUE %% 2 == 0 61 65 } 62 66 67 + #' @export 63 68 bn_append_s3 <- function(x, ll) { 64 69 UseMethod("bn_append_s3") 65 70 } 66 71 67 72 # TODO: fix this later 68 - bn_append_s3.linked_list <- function(x, ll) { 69 - if (is.na(ll$state$head)) { 73 + #' @export 74 + bn_append_s3.big_num_node_s3 <- function(x, ll) { 75 + if (!inherits(ll$state$head, "big_num_node_s3")) { 70 76 ll$state$head <- x 71 77 ll$state$tail <- x 72 78 } else { 73 - ll$state$tail@nxt <- x 79 + ll$state$tail$state$nxt <- x 74 80 ll$state$tail <- x 75 81 } 76 - ll@length <- ll@length + 1 82 + ll$state$length <- ll$state$length + 1 77 83 78 84 invisible(ll) 79 85 } 86 + 87 + #' @exportS3Method base::print 88 + print.big_num_linked_list_s3 <- function(x, ...) { 89 + current <- x$state$head 90 + while (inherits(current, "big_num_node_s3")) { 91 + cat(current$VALUE, "-> ") 92 + current <- current$state$nxt 93 + } 94 + cat("NA\n") 95 + 96 + invisible(x) 97 + } 98 + 99 + #' @exportS3Method base::print 100 + print.big_num_s3 <- function(x, ...) { 101 + len <- x$state$length 102 + 103 + if (len == 0) { 104 + return(cat("NA\n")) 105 + } 106 + 107 + stack <- character(len) 108 + current <- x$state$head 109 + 110 + for (i in len:1) { 111 + stack[i] <- current$VALUE 112 + current <- current$state$nxt 113 + } 114 + 115 + string <- paste0(stack, collapse = "") 116 + cat(string, "\n") 117 + }

+30 -2

R/big_num_S4.R

··· 1 - node_or_na_s4 <- function(value) is.na(value) || is(value, "big_num_node_s4") 1 + node_or_na_s4 <- function(value) is(value, "big_num_node_s4") || is.na(value) 2 2 3 3 setClass("big_num_node_s4", 4 4 slots = c( ··· 16 16 new("big_num_node_s4", VALUE = VALUE, state = rlang::new_environment(list(nxt = nxt))) 17 17 } 18 18 19 - # TODO: copy this in S3 to approximate read only properties 19 + # TODO: copy this in S3 to approximate read only properties? 20 20 setGeneric("nxt", function(x) standardGeneric("nxt")) 21 21 setMethod("nxt", "big_num_node_s4", function(x) x@state$nxt) 22 22 ··· 72 72 big_num_s4 <- function(num = "") { 73 73 as(linked_list_s4(num), "big_num_s4") 74 74 } 75 + 76 + setMethod("show", "big_num_linked_list_s4", function(object) { 77 + current <- object@state$head 78 + while (is(current, "big_num_node_s4")) { 79 + cat(current@VALUE, "-> ") 80 + current <- current@state$nxt 81 + } 82 + cat("NA\n") 83 + }) 84 + 85 + setMethod("show", "big_num_s4", function(object) { 86 + len <- object@state$length 87 + 88 + if (len == 0) { 89 + return(cat("NA\n")) 90 + } 91 + 92 + stack <- character(len) 93 + current <- object@state$head 94 + 95 + for (i in len:1) { 96 + stack[i] <- current@VALUE 97 + current <- current@state$nxt 98 + } 99 + 100 + string <- paste0(stack, collapse = "") 101 + cat(string, "\n") 102 + })

+1 -3

man/big_num.Rd

··· 10 10 \item{num}{A string representation of a num.} 11 11 } 12 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. 13 + TODO: WRITE THIS 16 14 17 15 The \code{big_num} class is essentially a wrapper around \link{linked_list} 18 16 with a custom print method as well as some defined operators such as

+15 -11

tests/testthat/test-big_num.R

··· 1 - rmpfr_test <- function(string_num_1, string_num_2) { 1 + rmpfr_test_multiplication <- function(string_num_1, string_num_2) { 2 2 # using Rmpfr to check big_num's accuracy 3 3 num <- Rmpfr::mpfr(string_num_1, 200) * Rmpfr::mpfr(string_num_2, 200) 4 4 string_num_solution <- as(num, "character") ··· 15 15 expect_equal(big_num(148) * big_num(997), big_num(147556)) 16 16 expect_equal(big_num(997) * big_num(148), big_num(147556)) 17 17 18 - rmpfr_test("11111111", "122333444455555") 19 - rmpfr_test("122333444455555", "11111111") 18 + rmpfr_test_multiplication("11111111", "122333444455555") 19 + rmpfr_test_multiplication("122333444455555", "11111111") 20 20 }) 21 21 22 22 test_that("multiplication big", { ··· 24 24 string_2 <- "46548999646551237776" 25 25 string_3 <- "21471047128412996458887978163" 26 26 27 - rmpfr_test(string_1, string_2) 28 - rmpfr_test(string_3, string_2) 27 + rmpfr_test_multiplication(string_1, string_2) 28 + rmpfr_test_multiplication(string_3, string_2) 29 29 }) 30 30 31 31 ··· 34 34 string_2 <- "46548999646551237776" 35 35 string_3 <- "21471047128412996458887978163" 36 36 37 - rmpfr_test(string_1, "0") 38 - rmpfr_test(string_2, "0") 39 - rmpfr_test(string_3, "0") 37 + rmpfr_test_multiplication(string_1, "0") 38 + rmpfr_test_multiplication(string_2, "0") 39 + rmpfr_test_multiplication(string_3, "0") 40 40 }) 41 41 42 42 ··· 45 45 string_2 <- "46548999646551237776" 46 46 string_3 <- "21471047128412996458887978163" 47 47 48 - rmpfr_test(string_1, "1") 49 - rmpfr_test(string_2, "1") 50 - rmpfr_test(string_3, "1") 48 + rmpfr_test_multiplication(string_1, "1") 49 + rmpfr_test_multiplication(string_2, "1") 50 + rmpfr_test_multiplication(string_3, "1") 51 51 }) 52 52 53 53 54 54 test_that("exponentiation works", { 55 + expect_equal(big_num(2)^0, big_num(1)) 56 + expect_equal(big_num(2)^1, big_num(2)) 55 57 expect_equal(big_num(2)^2, big_num(4)) 58 + 59 + expect_equal(big_num(11)^20, big_num("61159090448414546291")) 56 60 })

Configure Feed

Configure Feed