Rational Numbers: An example of R Classes

Why do we need a rational package?

This package serves 2 purposes:

Demonstrates the creation of the same classes in S3, S4, and R6 class systems
Demonstrates one way to solve some numerical accuracy problems that people struggle with

For example:

# expectations dashed
(0.1 + 0.2) == 0.3
#> [1] FALSE
# what?
print(0.1 + 0.2, digits = 20)
#> [1] 0.30000000000000004
# what am I supposed to do in R? (or any other floating point arithmetic system)
all.equal(0.1 + 0.2, 0.3, tolerance = 1E-9)
#> [1] TRUE
abs(0.1 + 0.2 - 0.3) < 1E-9
#> [1] TRUE
# is there another way?
# Yes, rational numbers
#   NOTE: the "L" notation indicates an integer
rational(1L, 10L) + rational(2L, 10L) == rational(3L, 10L)
#> [1] TRUE

Initialization

Rational S3

.rationalS3 <- function(n, d)
{
  ret <- list(n = n, d = d, v = n / d)
  class(ret) <- "rationalS3"
  return(ret)
}

# generating function
a <- rational(1L, 3L, method = "S3")
# basic structure
str(a)
#> Class 'rationalS3'  hidden list of 3
#>  $ n: int 1
#>  $ d: int 3
#>  $ v: num 0.333
# what is this object?
class(a)
#> [1] "rationalS3"
is.list(a)
#> [1] TRUE
is.rational(a)
#> [1] TRUE
is.rationalS3(a)
#> [1] TRUE
is.numeric(a)
#> [1] FALSE
is.integer(a)
#> [1] FALSE
# how can I access the values?
a$n
#> [1] 1
a$d
#> [1] 3
a$v
#> [1] 0.3333333

Rational S4

setClass("rationalS4", slots = c(n = "integer", d = "integer", v = "numeric"),
         valid = function(object)
         {
           if (length(object@n) == length(object@d)) {
             if (all(is.integer(object@n)) && all(is.integer(object@d))) {
               if (!any(object@d == 0)) return(TRUE)
               else return(.rationalErrorMessage2)
             }
             else return(.rationalErrorMessage1)
           }
           else return(.rationalErrorMessage3)
         })

setMethod("initialize", "rationalS4", function(.Object, n, d)
{
  .Object@n <- n
  .Object@d <- d
  .Object@v <- n / d
  # validity checks happen on the default initialize
  callNextMethod(.Object = .Object, n = n, d = d)
})

# generating function
a <- rational(1L, 3L, method = "S4")
# basic structure
str(a)
#> Formal class 'rationalS4' [package "rational"] with 3 slots
#>   ..@ n: int 1
#>   ..@ d: int 3
#>   ..@ v: num 0.333
# what is this object?
class(a)
#> [1] "rationalS4"
#> attr(,"package")
#> [1] "rational"
is.rational(a)
#> [1] TRUE
is.rationalS4(a)
#> [1] TRUE
is.numeric(a)
#> [1] FALSE
is.integer(a)
#> [1] FALSE
# how can I access the values?
a@n
#> [1] 1
a@d
#> [1] 3
a@v
#> [1] 0.3333333

Rational R6

.rationalR6 <- R6Class("rationalR6",
  public = list(
   getNumerator = function() private$n,
   getDenominator = function() private$d,
   getValue = function() private$v,
   initialize = function(n, d)
   {
     private$n <- n
     private$d <- d
     private$v <- n / d
     self
   },
   setNumerator = function(x)
   {
     private$n <- x
     private$v <- private$n / private$d
   },
   setDenominator = function(x)
   {
     private$d <- x
     private$v <- private$n / private$d
   },
   assign_at = function(i, value)
   {
     private$n[i] <- value$getNumerator()
     private$d[i] <- value$getDenominator()
     private$v <- private$n / private$d
   }),
  private = list(
   n = 1L,
   d = 1L,
   v = 1L
  ), lock_class = FALSE, lock_objects = TRUE, portable = TRUE)

# generating function
a <- rational(1L, 3L, method = "R6")
# basic structure
str(a)
#> Classes 'rationalR6', 'R6' <rationalR6>
#>   Public:
#>     add: function (e1) 
#>     assign_at: function (i, value) 
#>     clone: function (deep = FALSE) 
#>     divide: function (e1) 
#>     getDenominator: function () 
#>     getNumerator: function () 
#>     getValue: function () 
#>     initialize: function (n, d) 
#>     multiply: function (e1) 
#>     setDenominator: function (x) 
#>     setNumerator: function (x) 
#>     subtract: function (e1) 
#>   Private:
#>     d: 3
#>     n: 1
#>     v: 0.333333333333333
# what is this object?
class(a)
#> [1] "rationalR6" "R6"
is.rational(a)
#> [1] TRUE
is.rationalR6(a)
#> [1] TRUE
is.numeric(a)
#> [1] FALSE
is.integer(a)
#> [1] FALSE
# how can I access the values?
a$getNumerator()
#> [1] 1
a$getDenominator()
#> [1] 3
a$getValue()
#> [1] 0.3333333

Create operators

Addition

'+.rationalS3' <- function(e1, e2)
{
  if (is.rationalS3(e1) && is.rationalS3(e2))
  {
    res <- .rationalAddRational(e1$n, e1$d, e2$n, e2$d)
    return(.rationalS3(res$n, res$d))
  } else if (is.integer(e1) && is.rationalS3(e2))
  {
    res <- .rationalAddInteger(e2$n, e2$d, e1)
    return(.rationalS3(res$n, res$d))
  } else if (is.rationalS3(e1) && is.integer(e2))
  {
    res <- .rationalAddInteger(e1$n, e1$d, e2)
    return(.rationalS3(res$n, res$d))
  } else if (is.numeric(e1) && is.rationalS3(e2))
  {
    return(.rationalAddNumeric(e2$n, e2$d, e1))
  } else if (is.rationalS3(e1) && is.numeric(e2))
  {
    return(.rationalAddNumeric(e1$n, e1$d, e2))
  } else
  {
    return(NA)
  }
}

'+.rationalR6' <- function(e1, e2)
{
  if (is.rationalR6(e1) && is.rationalR6(e2))
  {
    res <- .rationalAddRational(e1$getNumerator(), e1$getDenominator(), 
                                e2$getNumerator(), e2$getDenominator())
    return(.rationalR6$new(res$n, res$d))
  } else if (is.integer(e1) && is.rationalR6(e2))
  {
    res <- .rationalAddInteger(e2$getNumerator(), e2$getDenominator(), e1)
    return(.rationalR6$new(res$n, res$d))
  } else if (is.rationalR6(e1) && is.integer(e2))
  {
    res <- .rationalAddInteger(e1$getNumerator(), e1$getDenominator(), e2)
    return(.rationalR6$new(res$n, res$d))
  } else if (is.numeric(e1) && is.rationalR6(e2))
  {
    return(.rationalAddNumeric(e2$getNumerator(), e2$getDenominator(), e1))
  } else if (is.rationalR6(e1) && is.numeric(e2))
  {
    return(.rationalAddNumeric(e1$getNumerator(), e1$getDenominator(), e2))
  } else
  {
    return(NA)
  }
}

setMethod("+", c("rationalS4", "rationalS4"), function(e1, e2)
{
  res <- .rationalAddRational(e1@n, e1@d, e2@n, e2@d)
  return(new("rationalS4", n = res$n, d = res$d))
})

setMethod("+", c("integer", "rationalS4"), function(e1, e2)
{
  res <- .rationalAddInteger(e2@n, e2@d, e1)
  return(new("rationalS4", n = res$n, d = res$d))
})

# and many more ...

a3 <- rational(1L, 3L, method = "S3")
b3 <- rational(3L, 4L, method = "S3")
a3 + 1.8
#> [1] 2.133333
a3 + 2L
#> [1] "(7 / 3) = 2.33333333333333"
a3 + b3
#> [1] "(13 / 12) = 1.08333333333333"

Other Operators

.rational_log <- function(n, d, base)
{
  if (base == exp(1))
    log(n) - log(d)
  else if (base == 10)
    log10(n) - log10(d)
  else if (base == 2)
    log2(n) - log2(d)
  else
    logb(n, base = base) - logb(d, base = base)
}

setMethod("log10", signature = c("rationalS4"),
  function(x)
  {
    .rational_log(x@n, x@d, 10)
  }
)

log10.rationalS3 <- function(x)
{
  .rational_log(x$n, x$d, 10)
}

log10.rationalR6 <- function(x)
{
  .rational_log(x$getNumerator(), x$getDenominator(), 10)
}

log10(rational(1L, 3L, method = "S3"))
#> [1] -0.4771213
log10(rational(3L, 4L, method = "R6"))
#> [1] -0.1249387
log10(rational(3L, 4L, method = "S4"))
#> [1] -0.1249387

Inheritance

S3

polygon <- function(area)
{
  value <- list(area = area)
  class(value) <- "polygonS3"
  return(value)
}

rectangle <- function(l, w)
{
  value <- list(area = l*w, l = l, w = w)
  class(value) <- c("rectangleS3", "polygonS3")
  return(value)
}

print.polygonS3 <- function(obj) cat("Area: ", obj$area, "\n")
print.rectangleS3 <- function(obj) 
{
  cat("Length: ", obj$l, " Width: ", obj$w, " ")
  print.polygonS3(obj)
}

p3 <- polygon(5)
r3 <- rectangle(2, 3)
is(p3, "polygonS3")
#> [1] TRUE
is(r3, "polygonS3")
#> [1] TRUE
is(r3, "rectangleS3")
#> [1] TRUE
inherits(r3, "polygonS3")
#> [1] TRUE
p3
#> Area:  5
r3
#> Length:  2  Width:  3  Area:  6

S4

setClass("polygonS4", slots = list(area = "numeric"))
setMethod("show", "polygonS4", function(object) cat("Area: ", object@area, "\n"))
setClass("rectangleS4", slots = list(l = "numeric", w = "numeric"),
         contains = "polygonS4")
setMethod("initialize", "rectangleS4", function(.Object, l, w)
{
  .Object@l <- l
  .Object@w <- w
  .Object@area <- l*w
  .Object
})
setMethod("show", "rectangleS4", function(object) 
{
  cat("Length: ", object@l, " Width: ", object@w, " ")
  callNextMethod()
})
p4 <- new("polygonS4", area = 5)
r4 <- new("rectangleS4", l = 2, w = 3)
is(p4, "polygonS4")
#> [1] TRUE
is(r4, "polygonS4")
#> [1] TRUE
is(r4, "rectangleS4")
#> [1] TRUE
inherits(r4, "polygonS4")
#> [1] TRUE
p4
#> Area:  5
r4
#> Length:  2  Width:  3  Area:  6

R6

polygonR6 <- R6Class("polygonR6",
  public = list(
    initialize = function(area)
    {
      private$area = area
    },
    print = function()
    {
      cat("Area: ", private$area, "\n")
    }
  ),
  private = list(
    area = numeric()
  )
)

rectangleR6 <- R6Class("rectangleR6",
  inherit = polygonR6,
  public = list(
    initialize = function(l, w)
    {
      private$l = l
      private$w = w
      private$area = l*w
    },
    print = function()
    {
      cat("Length: ", private$l, " Width: ", private$w, " ")
      super$print()
    }
  ),
  private = list(
    l = numeric(),
    w = numeric()
  )
)
p6 <- polygonR6$new(area = 5)
r6 <- rectangleR6$new(l = 2, w = 3)
is(p6, "polygonR6")
#> [1] TRUE
is(r6, "polygonR6")
#> [1] TRUE
is(r6, "rectangleR6")
#> [1] TRUE
inherits(r6, "polygonR6")
#> [1] TRUE
p6
#> Area:  5
r6
#> Length:  2  Width:  3  Area:  6

Encapsulation

S3 + S4

There is no encapsulation in the S3 and S4 system. All objects of the class can be accessed directly. There is no concept of “public” and “private” in the class.

r3$l <- 10
# this is bad
r3
#> Length:  10  Width:  3  Area:  6

r4@l <- 10
# so is this
r4
#> Length:  10  Width:  3  Area:  6

# R6 solves this problem
tryCatch(r6$l <- 10, error = function(e) print(e)) 
#> <simpleError in r6$l <- 10: cannot add bindings to a locked environment>

R6

With R6, we can restrict the method users use to interact with the class.

rectangleR6$set("public", "setLength", function(l){
  private$l <- l
  private$area <- l * private$w
})
r6 <- rectangleR6$new(2, 3)
r6$setLength(10)
r6
#> Length:  10  Width:  3  Area:  30

Rob Carnell

2019-01-27