14_R6.Rmd

```{r, include = FALSE}
source("common.R")
```

# R6
<!-- 14 -->

## Prerequisites {-}
<!-- 14.0 -->

To solve the exercises in this chapter we will have to create R6 objects, which are implemented in the `{R6}` package [@R6].

```{r}
library(R6)
```

\stepcounter{section}
## Classes and methods
<!-- 14.2 -->

__[Q1]{.Q}__: 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.

__[A]{.solved}__: Let's start with a basic bank account, similar to the `Accumulator` class in *Advanced R*.

```{r}
BankAccount <- R6Class(
  classname = "BankAccount", 
  public = list(
    balance = 0,
    deposit = function(dep = 0) {
      self$balance <- self$balance + dep
      invisible(self)
    },
    withdraw = function(draw) {
      self$balance <- self$balance - draw
      invisible(self)
    }
  )
)
```

To test this class, we create one instance and leave it with a negative balance.

```{r}
my_account <- BankAccount$new()
my_account$balance

my_account$
  deposit(5)$
  withdraw(15)$
  balance
```

Now, we create the first subclass that prevents us from going into overdraft and throws an error in case we attempt to withdraw more than our current balance.

```{r}
BankAccountStrict <- R6Class(
  classname = "BankAccountStrict",
  inherit = BankAccount,
  public = list(
    withdraw = function(draw = 0) {
      if (self$balance - draw < 0) {
        stop("Your `withdraw` must be smaller ",
          "than your `balance`.",
          call. = FALSE
        )
      }
      super$withdraw(draw = draw)
    }
  )
)
```

This time our test should throw an error.

```{r, error = TRUE}
my_strict_account <- BankAccountStrict$new()
my_strict_account$balance

my_strict_account$
  deposit(5)$
  withdraw(15)

my_strict_account$balance
```

Finally, we create another subclass that charges a constant fee of 1 for each withdrawal which leaves the account with a negative balance.

```{r}
BankAccountCharging <- R6Class(
  classname = "BankAccountCharging",
  inherit = BankAccount,
  public = list(
    withdraw = function(draw = 0) {
      if (self$balance - draw < 0) {
        draw <- draw + 1
      }
      super$withdraw(draw = draw)
    }
  )
)
```

Let's take a look at the implemented functionality. We expect a final balance of -12,  because we pay the fee twice.

```{r}
my_charging_account <- BankAccountCharging$new()
my_charging_account$balance

my_charging_account$
  deposit(5)$
  withdraw(15)$
  withdraw(0)

my_charging_account$balance
```

__[Q2]{.Q}__: 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.

```{r}
suit <- c("SPADE", "HEARTS", "DIAMOND", "CLUB")
value <- c("A", 2:10, "J", "Q", "K")
cards <- paste(rep(value, 4), suit)
```

*(This question was altered slightly to avoid the unicode characters.)*

__[A]{.solved}__: Our new `ShuffledDeck` class will use `sample()` and positive integer subsetting to implement the reshuffling and drawing functionality. We also add a check, so you cannot draw more cards than there are left in the deck.

```{r}
ShuffledDeck <- R6Class(
  classname = "ShuffledDeck",
  public = list(
    deck = NULL,
    initialize = function(deck = cards) {
      self$deck <- sample(deck)
    },
    reshuffle = function() {
      self$deck <- sample(cards)
      invisible(self)
    },
    n = function() {
      length(self$deck)
    },
    draw = function(n = 1) {
      if (n > self$n()) {
        stop("Only ", self$n(), " cards remaining.", call. = FALSE)
      }

      output <- self$deck[seq_len(n)]
      self$deck <- self$deck[-seq_len(n)]
      output
    }
  )
)
```

To test this class, we create a deck (initialise an instance), draw all the cards, then reshuffle, checking we get different cards each time.

```{r, error = TRUE}
my_deck <- ShuffledDeck$new()

my_deck$draw(52)
my_deck$draw(10)

my_deck$reshuffle()$draw(5)
my_deck$reshuffle()$draw(5)
```

__[Q3]{.Q}__: Why can't you model a bank account or a deck of cards with an S3 class?

__[A]{.solved}__: Because S3 classes obey R's usual semantics of copy-on-modify: every time you deposit money into your bank account or draw a card from the deck, you'd get a new copy of the object.

It is possible to combine S3 classes with an environment (which is how R6 works), but it is ill-advised to create an object that looks like a regular R object but has reference semantics.

__[Q4]{.Q}__: 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()`.

__[A]{.solved}__: To create an R6 class that allows us to get and set the time zone, we provide the respective functions as public methods to the R6 class.

```{r}
Timezone <- R6Class(
  classname = "Timezone",
  public = list(
    get = function() {
      Sys.timezone()
    },
    set = function(value) {
      stopifnot(value %in% OlsonNames())

      old <- self$get()
      Sys.setenv(TZ = value)
      invisible(old)
    }
  )
)
```

(When setting, we return the old value invisibly because this makes it easy to restore the previous value.)

Now, let us create one instance of this class and test, if we can set and get the time zone as intended.

```{r}
tz <- Timezone$new()

old <- tz$set("Antarctica/South_Pole")
tz$get()

tz$set(old)
tz$get()
```

__[Q5]{.Q}__: Create an R6 class that manages the current working directory. It should have `$get()` and `$set()` methods.

__[A]{.solved}__: Take a look at the following implementation, which is quite minimalistic:

```{r}
WorkingDirectory <- R6Class(
  classname = "WorkingDirectory",
  public = list(
    get = function() {
      getwd()
    },
    set = function(value) {
      setwd(value)
    }
  )
)
```

<!-- HW: You should never do get = getwd() etc because in packages, that inlines the function definition at package build time, creating a subtle dependency that will cause bugs that are extremely difficult to track down -->

__[Q6]{.Q}__: Why can't you model the time zone or current working directory with an S3 class?

__[A]{.solved}__: Because S3 classes are not suitable for modelling a state that changes over time. S3 methods should (almost) always return the same result when called with the same inputs.

__[Q7]{.Q}__: What base type are R6 objects built on top of? What attributes do they have?

__[A]{.solved}__: R6 objects are built on top of environments. They have a `class` attribute, which is a character vector containing the class name, the name of any super classes (if existent) and the string `"R6"` as the last element.

## Controlling access
<!-- 14.3 -->

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

__[A]{.solved}__: To fulfil this requirement, we make balance a private field. The user has to use the `$deposit()` and `$withdraw()` methods which have access to the balance field.

```{r, error = TRUE}
BankAccountStrict2 <- R6Class(
  classname = "BankAccountStrict2",
  public = list(
    deposit = function(dep = 0) {
      private$balance <- private$balance + dep
      invisible(self)
    },
    withdraw = function(draw = 0) {
      if (private$balance - draw < 0) {
        stop(
          "Your `withdraw` must be smaller ",
          "than your `balance`.",
          call. = FALSE
        )
      }
      private$balance <- private$balance - draw
      invisible(self)
    }
  ),
  private = list(
    balance = 0
  )
)
```

To test our new class, we create an instance and try to go into overdraft.

```{r, error = TRUE}
my_account_strict_2 <- BankAccountStrict2$new()

my_account_strict_2$deposit(5)
my_account_strict_2$withdraw(10)
```

__[Q2]{.Q}__: 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.

__[A]{.solved}__: To protect the password from changes and direct access, the password will be a private field. Further, our `Password` will get its own print method which hides the password.

```{r}
Password <- R6Class(
  classname = "Password",
  public = list(
    print = function(...) {
      cat("<Password>: ********\n")
      invisible(self)
    },
    set = function(value) {
      private$password <- value
    },
    check = function(password) {
      identical(password, private$password)
    }
  ),
  private = list(
    password = NULL
  )
)
```

Let's create one instance of our new class and confirm that the password is neither accessible nor visible, but still check-able.

```{r, error = TRUE}
my_pw <- Password$new()
my_pw$set("snuffles")
my_pw$password
my_pw
my_pw$check("snuggles")
my_pw$check("snuffles")
```

__[Q3]{.Q}__: 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.

__[A]{.solved}__: To access the previous random value from an instance, we add a private `$last_random` field to our class, and we modify `$random()` to write to this field, whenever it is called. To access the `$last_random` field we provide `$previous()`.

```{r}
Rando <- R6::R6Class(
  classname = "Rando",
  private = list(
    last_random = NULL
  ),
  active = list(
    random = function(value) {
      if (missing(value)) {
        private$last_random <- runif(1)
        private$last_random
      } else {
        stop("Can't set `$random`.", call. = FALSE)
      }
    },
    previous = function(value) {
      if (missing(value)) {
        private$last_random
      }
    }
  )
)
```

Now, we initiate a new `Rando` object and see if it behaves as expected.

```{r}
x <- Rando$new()
x$random
x$random
x$previous
```

__[Q4]{.Q}__: Can subclasses access private fields/methods from their parent? Perform an experiment to find out.

__[A]{.solved}__: To find out if private fields/methods can be accessed from subclasses, we first create a class `A` with a private field `foo` and a private method `bar()`. Afterwards, an instance of a subclass `B`  is created and calls the `foobar()` methods, which tries to access the `foo` field and the `bar()` method from its superclass `A`.

```{r}
A <- R6Class(
  classname = "A",
  private = list(
    field = "foo",
    method = function() {
      "bar"
    }
  )
)

B <- R6Class(
  classname = "B",
  inherit = A,
  public = list(
    test = function() {
      cat("Field:  ", super$field, "\n", sep = "")
      cat("Method: ", super$method(), "\n", sep = "")
    }
  )
)

B$new()$test()
```

We conclude that subclasses can access private methods from their superclasses, but not private fields.

## Reference semantics
<!-- 14.4 -->

__[Q1]{.Q}__: 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()`.

__[A]{.solved}__: Our `FileWriter` class will create a connection to a file at initialization. Therefore, we open a connection to a user specified file during the initialisation. Note that we need to set `open = "a"` in `file()` to open connection for appending text. Otherwise, `cat()` would only work when applied to files, but not with connections as explicitly asked for in the exercise. Further, we add the `append_line()` method and a `close()` statement as finalizer.

```{r, eval = TRUE, error = TRUE}
FileWriter <- R6::R6Class(
  classname = "FileWriter",
  public = list(
    con = NULL,
    initialize = function(filename) {
      self$con <- file(filename, open = "a")
    },

    finalize = function() {
      close(self$con)
    },

    append_line = function(x) {
      cat(x, "\n", sep = "", file = self$con)
    }
  )
)
```

Let's see, if new instances of our class work as expected.

```{r}
tmp_file <- tempfile()
my_fw <- FileWriter$new(tmp_file)

readLines(tmp_file)
my_fw$append_line("First")
my_fw$append_line("Second")
readLines(tmp_file)
```