14 R6

Loading the needed libraries:

library(R6)

14.1 Classes and methods (Exercises 14.2.6)

Q1. Create a bank account R6 class that stores a balance and allows you to deposit and withdraw money. Create a subclass that throws an error if you attempt to go into overdraft. Create another subclass that allows you to go into overdraft, but charges you a fee. Create the superclass and make sure it works as expected.

A1. First, let’s create a bank account R6 class that stores a balance and allows you to deposit and withdraw money:

library(R6)

bankAccount <- R6::R6Class(
  "bankAccount",
  public = list(
    balance = 0,
    initialize = function(balance) {
      self$balance <- balance
    },
    deposit = function(amount) {
      self$balance <- self$balance + amount
      message(paste0("Current balance is: ", self$balance))
      invisible(self)
    },
    withdraw = function(amount) {
      self$balance <- self$balance - amount
      message(paste0("Current balance is: ", self$balance))
      invisible(self)
    }
  )
)

Let’s try it out:

indra <- bankAccount$new(balance = 100)

indra$deposit(20)
#> Current balance is: 120

indra$withdraw(10)
#> Current balance is: 110

Create a subclass that errors if you attempt to overdraw:

bankAccountStrict <- R6::R6Class(
  "bankAccountStrict",
  inherit = bankAccount,
  public = list(
    withdraw = function(amount) {
      if (self$balance - amount < 0) {
        stop(
          paste0("Can't withdraw more than your current balance: ", self$balance),
          call. = FALSE
        )
      }

      super$withdraw(amount)
    }
  )
)

Let’s try it out:

Pritesh <- bankAccountStrict$new(balance = 100)

Pritesh$deposit(20)
#> Current balance is: 120

Pritesh$withdraw(150)
#> Error: Can't withdraw more than your current balance: 120

Now let’s create a subclass that charges a fee if account is overdrawn:

bankAccountFee <- R6::R6Class(
  "bankAccountFee",
  inherit = bankAccount,
  public = list(
    withdraw = function(amount) {
      super$withdraw(amount)

      if (self$balance) {
        self$balance <- self$balance - 10
        message("You're withdrawing more than your current balance. You will be charged a fee of 10 euros.")
      }
    }
  )
)

Let’s try it out:

Mangesh <- bankAccountFee$new(balance = 100)

Mangesh$deposit(20)
#> Current balance is: 120

Mangesh$withdraw(150)
#> Current balance is: -30
#> You're withdrawing more than your current balance. You will be charged a fee of 10 euros.

Q2. Create an R6 class that represents a shuffled deck of cards. You should be able to draw cards from the deck with $draw(n), and return all cards to the deck and reshuffle with $reshuffle(). Use the following code to make a vector of cards.

suit <- c("♠", "♥", "♦", "♣")
value <- c("A", 2:10, "J", "Q", "K")
cards <- paste0(rep(value, 4), suit)

A2. Let’s create needed class that represents a shuffled deck of cards:

suit <- c("♠", "♥", "♦", "♣")
value <- c("A", 2:10, "J", "Q", "K")
cards <- paste(rep(value, 4), suit)

Deck <- R6::R6Class(
  "Deck",
  public = list(
    initialize = function(deck) {
      private$cards <- sample(deck)
    },
    draw = function(n) {
      if (n > length(private$cards)) {
        stop(
          paste0("Can't draw more than remaining number of cards: ", length(private$cards)),
          call. = FALSE
        )
      }

      drawn_cards <- sample(private$cards, n)
      private$cards <- private$cards[-which(private$cards %in% drawn_cards)]
      message(paste0("Remaining number of cards: ", length(private$cards)))

      return(drawn_cards)
    },
    reshuffle = function() {
      private$cards <- sample(private$cards)
      invisible(self)
    }
  ),
  private = list(
    cards = NULL
  )
)

Let’s try it out:

myDeck <- Deck$new(cards)

myDeck$draw(4)
#> Remaining number of cards: 48
#> [1] "2 ♠"  "10 ♦" "9 ♦"  "3 ♦"

myDeck$reshuffle()$draw(5)
#> Remaining number of cards: 43
#> [1] "6 ♦"  "10 ♥" "2 ♥"  "A ♥"  "8 ♥"

myDeck$draw(50)
#> Error: Can't draw more than remaining number of cards: 43

Q3. Why can’t you model a bank account or a deck of cards with an S3 class?

A3. We can’t model a bank account or a deck of cards with an S3 class because instances of these classes are immutable.

On the other hand, R6 classes encapsulate data and represent its state, which can change over the course of object’s lifecycle. In other words, these objects are mutable and well-suited to model a bank account.

Q4. Create an R6 class that allows you to get and set the current time zone. You can access the current time zone with Sys.timezone() and set it with Sys.setenv(TZ = "newtimezone"). When setting the time zone, make sure the new time zone is in the list provided by OlsonNames().

A4. Here is an R6 class that manages the current time zone:

CurrentTimeZone <- R6::R6Class("CurrentTimeZone",
  public = list(
    setTimeZone = function(tz) {
      stopifnot(tz %in% OlsonNames())
      Sys.setenv(TZ = tz)
    },
    getTimeZone = function() {
      Sys.timezone()
    }
  )
)

Let’s try it out:

myCurrentTimeZone <- CurrentTimeZone$new()

myCurrentTimeZone$getTimeZone()
#> [1] "UTC"

myCurrentTimeZone$setTimeZone("Asia/Kolkata")
myCurrentTimeZone$getTimeZone()
#> [1] "Asia/Kolkata"

myCurrentTimeZone$setTimeZone("Europe/Berlin")

Q5. Create an R6 class that manages the current working directory. It should have $get() and $set() methods.

A5. Here is an R6 class that manages the current working directory:

ManageDirectory <- R6::R6Class("ManageDirectory",
  public = list(
    setWorkingDirectory = function(dir) {
      setwd(dir)
    },
    getWorkingDirectory = function() {
      getwd()
    }
  )
)

Let’s create an instance of this class and check if the methods work as expected:

myDirManager <- ManageDirectory$new()

# current working directory
myDirManager$getWorkingDirectory()

# change and check if that worked
myDirManager$setWorkingDirectory("..")
myDirManager$getWorkingDirectory()

# revert this change
myDirManager$setWorkingDirectory("/Advanced-R-exercises")

Q6. Why can’t you model the time zone or current working directory with an S3 class?

A6. Same as answer to Q3:

Objects that represent these real-life entities need to be mutable and S3 class instances are not mutable.

Q7. What base type are R6 objects built on top of? What attributes do they have?

A7. Let’s create an example class and create instance of that class:

Example <- R6::R6Class("Example")
myExample <- Example$new()

The R6 objects are built on top of environment:

typeof(myExample)
#> [1] "environment"

rlang::env_print(myExample)
#> <environment: 0x562ae7d1e4b0> [L]
#> Parent: <environment: empty>
#> Class: Example, R6
#> Bindings:
#> • .__enclos_env__: <env>
#> • clone: <fn> [L]

And it has only class attribute, which is a character vector with the "R6" being the last element and the superclasses being other elements:

attributes(myExample)
#> $class
#> [1] "Example" "R6"

14.2 Controlling access (Exercises 14.3.3)

Q1. Create a bank account class that prevents you from directly setting the account balance, but you can still withdraw from and deposit to. Throw an error if you attempt to go into overdraft.

A1. Here is a bank account class that satisfies the specified requirements:

SafeBankAccount <- R6::R6Class(
  classname = "SafeBankAccount",
  public = list(
    deposit = function(deposit_amount) {
      private$.balance <- private$.balance + deposit_amount
      print(paste("Current balance:", private$.balance))

      invisible(self)
    },
    withdraw = function(withdrawal_amount) {
      if (withdrawal_amount > private$.balance) {
        stop("You can't withdraw more than your current balance.", call. = FALSE)
      }

      private$.balance <- private$.balance - withdrawal_amount
      print(paste("Current balance:", private$.balance))

      invisible(self)
    }
  ),
  private = list(
    .balance = 0
  )
)

Let’s check if it works as expected:

mySafeBankAccount <- SafeBankAccount$new()

mySafeBankAccount$deposit(100)
#> [1] "Current balance: 100"

mySafeBankAccount$withdraw(50)
#> [1] "Current balance: 50"

mySafeBankAccount$withdraw(100)
#> Error: You can't withdraw more than your current balance.

Q2. Create a class with a write-only $password field. It should have $check_password(password) method that returns TRUE or FALSE, but there should be no way to view the complete password.

A2. Here is an implementation of the class with the needed properties:

library(R6)

checkCredentials <- R6Class(
  "checkCredentials",
  public = list(
    # setter
    set_password = function(password) {
      private$.password <- password
    },

    # checker
    check_password = function(password) {
      if (is.null(private$.password)) {
        stop("No password set to check against.")
      }

      identical(password, private$.password)
    },

    # the default print method prints the private fields as well
    print = function() {
      cat("Password: XXXX")

      # for method chaining
      invisible(self)
    }
  ),
  private = list(
    .password = NULL
  )
)

myCheck <- checkCredentials$new()

myCheck$set_password("1234")
print(myCheck)
#> Password: XXXX

myCheck$check_password("abcd")
#> [1] FALSE
myCheck$check_password("1234")
#> [1] TRUE

But, of course, everything is possible:

myCheck$.__enclos_env__$private$.password
#> [1] "1234"

Q3. Extend the Rando class with another active binding that allows you to access the previous random value. Ensure that active binding is the only way to access the value.

A3. Here is a modified version of the Rando class to meet the specified requirements:

Rando <- R6::R6Class("Rando",
  active = list(
    random = function(value) {
      if (missing(value)) {
        newValue <- runif(1)
        private$.previousRandom <- private$.currentRandom
        private$.currentRandom <- newValue
        return(private$.currentRandom)
      } else {
        stop("Can't set `$random`", call. = FALSE)
      }
    },
    previousRandom = function(value) {
      if (missing(value)) {
        if (is.null(private$.previousRandom)) {
          message("No random value has been generated yet.")
        } else {
          return(private$.previousRandom)
        }
      } else {
        stop("Can't set `$previousRandom`", call. = FALSE)
      }
    }
  ),
  private = list(
    .currentRandom = NULL,
    .previousRandom = NULL
  )
)

Let’s try it out:

myRando <- Rando$new()

# first time
myRando$random
#> [1] 0.5549124
myRando$previousRandom
#> No random value has been generated yet.
#> NULL

# second time
myRando$random
#> [1] 0.3482785
myRando$previousRandom
#> [1] 0.5549124

# third time
myRando$random
#> [1] 0.2187275
myRando$previousRandom
#> [1] 0.3482785

Q4. Can subclasses access private fields/methods from their parent? Perform an experiment to find out.

A4. Unlike common OOP in other languages (e.g. C++), R6 subclasses (or derived classes) also have access to the private methods in superclass (or base class).

For instance, in the following example, the Duck class has a private method $quack(), but its subclass Mallard can access it using super$quack().

Duck <- R6Class("Duck",
  private = list(quack = function() print("Quack Quack"))
)

Mallard <- R6Class("Mallard",
  inherit = Duck,
  public = list(quack = function() super$quack())
)

myMallard <- Mallard$new()
myMallard$quack()
#> [1] "Quack Quack"

14.3 Reference semantics (Exercises 14.4.4)

Q1. Create a class that allows you to write a line to a specified file. You should open a connection to the file in $initialize(), append a line using cat() in $append_line(), and close the connection in $finalize().

A1. Here is a class that allows you to write a line to a specified file:

fileEditor <- R6Class(
  "fileEditor",
  public = list(
    initialize = function(filePath) {
      private$.connection <- file(filePath, open = "wt")
    },
    append_line = function(text) {
      cat(
        text,
        file = private$.connection,
        sep = "\n",
        append = TRUE
      )
    }
  ),
  private = list(
    .connection = NULL,
    # according to R6 docs, the destructor method should be private
    finalize = function() {
      print("Closing the file connection!")
      close(private$.connection)
    }
  )
)

Let’s check if it works as expected:

greetMom <- function() {
  f <- tempfile()
  myfileEditor <- fileEditor$new(f)

  readLines(f)

  myfileEditor$append_line("Hi mom!")
  myfileEditor$append_line("It's a beautiful day!")

  readLines(f)
}

greetMom()
#> [1] "Hi mom!"               "It's a beautiful day!"

# force garbage collection
gc()
#> [1] "Closing the file connection!"
#>           used (Mb) gc trigger (Mb) max used (Mb)
#> Ncells  761091 40.7    1420394 75.9  1420394 75.9
#> Vcells 1403305 10.8    8388608 64.0  2668757 20.4

14.4 Session information

sessioninfo::session_info(include_base = TRUE)
#> ─ Session info ───────────────────────────────────────────
#>  setting  value
#>  version  R version 4.4.1 (2024-06-14)
#>  os       Ubuntu 22.04.4 LTS
#>  system   x86_64, linux-gnu
#>  ui       X11
#>  language (EN)
#>  collate  C.UTF-8
#>  ctype    C.UTF-8
#>  tz       Europe/Berlin
#>  date     2024-09-15
#>  pandoc   3.4 @ /opt/hostedtoolcache/pandoc/3.4/x64/ (via rmarkdown)
#> 
#> ─ Packages ───────────────────────────────────────────────
#>  package     * version date (UTC) lib source
#>  base        * 4.4.1   2024-08-22 [3] local
#>  bookdown      0.40    2024-07-02 [1] RSPM
#>  bslib         0.8.0   2024-07-29 [1] RSPM
#>  cachem        1.1.0   2024-05-16 [1] RSPM
#>  cli           3.6.3   2024-06-21 [1] RSPM
#>  compiler      4.4.1   2024-08-22 [3] local
#>  datasets    * 4.4.1   2024-08-22 [3] local
#>  digest        0.6.37  2024-08-19 [1] RSPM
#>  downlit       0.4.4   2024-06-10 [1] RSPM
#>  evaluate      0.24.0  2024-06-10 [1] RSPM
#>  fansi         1.0.6   2023-12-08 [1] RSPM
#>  fastmap       1.2.0   2024-05-15 [1] RSPM
#>  fs            1.6.4   2024-04-25 [1] RSPM
#>  glue          1.7.0   2024-01-09 [1] RSPM
#>  graphics    * 4.4.1   2024-08-22 [3] local
#>  grDevices   * 4.4.1   2024-08-22 [3] local
#>  htmltools     0.5.8.1 2024-04-04 [1] RSPM
#>  jquerylib     0.1.4   2021-04-26 [1] RSPM
#>  jsonlite      1.8.8   2023-12-04 [1] RSPM
#>  knitr         1.48    2024-07-07 [1] RSPM
#>  lifecycle     1.0.4   2023-11-07 [1] RSPM
#>  magrittr    * 2.0.3   2022-03-30 [1] RSPM
#>  memoise       2.0.1   2021-11-26 [1] RSPM
#>  methods     * 4.4.1   2024-08-22 [3] local
#>  pillar        1.9.0   2023-03-22 [1] RSPM
#>  R6          * 2.5.1   2021-08-19 [1] RSPM
#>  rlang         1.1.4   2024-06-04 [1] RSPM
#>  rmarkdown     2.28    2024-08-17 [1] RSPM
#>  sass          0.4.9   2024-03-15 [1] RSPM
#>  sessioninfo   1.2.2   2021-12-06 [1] RSPM
#>  stats       * 4.4.1   2024-08-22 [3] local
#>  tools         4.4.1   2024-08-22 [3] local
#>  utf8          1.2.4   2023-10-22 [1] RSPM
#>  utils       * 4.4.1   2024-08-22 [3] local
#>  vctrs         0.6.5   2023-12-01 [1] RSPM
#>  withr         3.0.1   2024-07-31 [1] RSPM
#>  xfun          0.47    2024-08-17 [1] RSPM
#>  xml2          1.3.6   2023-12-04 [1] RSPM
#>  yaml          2.3.10  2024-07-26 [1] RSPM
#> 
#>  [1] /home/runner/work/_temp/Library
#>  [2] /opt/R/4.4.1/lib/R/site-library
#>  [3] /opt/R/4.4.1/lib/R/library
#> 
#> ──────────────────────────────────────────────────────────