R6.Rmd

# R6

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

Loading the needed libraries:

```{r R6-2, warning=FALSE, message=FALSE}
library(R6)
```

## 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:

```{r R6-3}
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:

```{r R6-4}
indra <- bankAccount$new(balance = 100)

indra$deposit(20)

indra$withdraw(10)
```

Create a subclass that errors if you attempt to overdraw:

```{r R6-5}
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:

```{r R6-6, error=TRUE}
Pritesh <- bankAccountStrict$new(balance = 100)

Pritesh$deposit(20)

Pritesh$withdraw(150)
```

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

```{r R6-7}
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:

```{r R6-8}
Mangesh <- bankAccountFee$new(balance = 100)

Mangesh$deposit(20)

Mangesh$withdraw(150)
```

**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.

```{r R6-9}
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:

```{r R6-10}
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:

```{r R6-11, error=TRUE}
myDeck <- Deck$new(cards)

myDeck$draw(4)

myDeck$reshuffle()$draw(5)

myDeck$draw(50)
```

**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:

```{r R6-12}
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:

```{r R6-13}
myCurrentTimeZone <- CurrentTimeZone$new()

myCurrentTimeZone$getTimeZone()

myCurrentTimeZone$setTimeZone("Asia/Kolkata")
myCurrentTimeZone$getTimeZone()

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:

```{r R6-14}
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:

```{r R6-15, eval=FALSE}
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:

```{r R6-16}
Example <- R6::R6Class("Example")
myExample <- Example$new()
```

The `R6` objects are built on top of environment:

```{r R6-17}
typeof(myExample)

rlang::env_print(myExample)
```

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

```{r R6-18}
attributes(myExample)
```

## 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:

```{r R6-19}
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:

```{r R6-20, error=TRUE}
mySafeBankAccount <- SafeBankAccount$new()

mySafeBankAccount$deposit(100)

mySafeBankAccount$withdraw(50)

mySafeBankAccount$withdraw(100)
```

**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:

```{r R6-21}
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)

myCheck$check_password("abcd")
myCheck$check_password("1234")
```

But, of course, everything is possible:

```{r R6-22}
myCheck$.__enclos_env__$private$.password
```

**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:

```{r R6-23}
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:

```{r R6-24}
myRando <- Rando$new()

# first time
myRando$random
myRando$previousRandom

# second time
myRando$random
myRando$previousRandom

# third time
myRando$random
myRando$previousRandom
```

**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()`.

```{r R6-25}
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()
```

## 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:

```{r R6-26}
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:

```{r R6-27}
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()

# force garbage collection
gc()
```

## Session information

```{r R6-28}
sessioninfo::session_info(include_base = TRUE)
```