## ----echo = FALSE--------------------------------------------------------
library(pryr)
knitr::opts_chunk$set(collapse = TRUE, comment = "#>")
## ------------------------------------------------------------------------
library(R6)
Person <- R6Class("Person",
public = list(
name = NA,
hair = NA,
initialize = function(name, hair) {
if (!missing(name)) self$name <- name
if (!missing(hair)) self$hair <- hair
self$greet()
},
set_hair = function(val) {
self$hair <- val
},
greet = function() {
cat(paste0("Hello, my name is ", self$name, ".\n"))
}
)
)
## ------------------------------------------------------------------------
ann <- Person$new("Ann", "black")
ann
## ------------------------------------------------------------------------
ann$hair
ann$greet()
ann$set_hair("red")
ann$hair
## ------------------------------------------------------------------------
Queue <- R6Class("Queue",
public = list(
initialize = function(...) {
for (item in list(...)) {
self$add(item)
}
},
add = function(x) {
private$queue <- c(private$queue, list(x))
invisible(self)
},
remove = function() {
if (private$length() == 0) return(NULL)
# Can use private$queue for explicit access
head <- private$queue[[1]]
private$queue <- private$queue[-1]
head
}
),
private = list(
queue = list(),
length = function() base::length(private$queue)
)
)
q <- Queue$new(5, 6, "foo")
## ------------------------------------------------------------------------
# Add and remove items
q$add("something")
q$add("another thing")
q$add(17)
q$remove()
q$remove()
## ----eval = FALSE--------------------------------------------------------
# q$queue
# #> NULL
# q$length()
# #> Error: attempt to apply non-function
## ------------------------------------------------------------------------
q$add(10)$add(11)$add(12)
## ------------------------------------------------------------------------
q$remove()
q$remove()
q$remove()
q$remove()
## ------------------------------------------------------------------------
Numbers <- R6Class("Numbers",
public = list(
x = 100
),
active = list(
x2 = function(value) {
if (missing(value)) return(self$x * 2)
else self$x <- value/2
},
rand = function() rnorm(1)
)
)
n <- Numbers$new()
n$x
## ------------------------------------------------------------------------
n$x2
## ------------------------------------------------------------------------
n$x2 <- 1000
n$x
## ----eval=FALSE----------------------------------------------------------
# n$rand
# #> [1] 0.2648
# n$rand
# #> [1] 2.171
# n$rand <- 3
# #> Error: unused argument (quote(3))
## ------------------------------------------------------------------------
# Note that this isn't very efficient - it's just for illustrating inheritance.
HistoryQueue <- R6Class("HistoryQueue",
inherit = Queue,
public = list(
show = function() {
cat("Next item is at index", private$head_idx + 1, "\n")
for (i in seq_along(private$queue)) {
cat(i, ": ", private$queue[[i]], "\n", sep = "")
}
},
remove = function() {
if (private$length() - private$head_idx == 0) return(NULL)
private$head_idx <<- private$head_idx + 1
private$queue[[private$head_idx]]
}
),
private = list(
head_idx = 0
)
)
hq <- HistoryQueue$new(5, 6, "foo")
hq$show()
hq$remove()
hq$show()
hq$remove()
## ------------------------------------------------------------------------
CountingQueue <- R6Class("CountingQueue",
inherit = Queue,
public = list(
add = function(x) {
private$total <<- private$total + 1
super$add(x)
},
get_total = function() private$total
),
private = list(
total = 0
)
)
cq <- CountingQueue$new("x", "y")
cq$get_total()
cq$add("z")
cq$remove()
cq$remove()
cq$get_total()
## ------------------------------------------------------------------------
SimpleClass <- R6Class("SimpleClass",
public = list(x = NULL)
)
SharedField <- R6Class("SharedField",
public = list(
e = SimpleClass$new()
)
)
s1 <- SharedField$new()
s1$e$x <- 1
s2 <- SharedField$new()
s2$e$x <- 2
# Changing s2$e$x has changed the value of s1$e$x
s1$e$x
## ------------------------------------------------------------------------
NonSharedField <- R6Class("NonSharedField",
public = list(
e = NULL,
initialize = function() self$e <- SimpleClass$new()
)
)
n1 <- NonSharedField$new()
n1$e$x <- 1
n2 <- NonSharedField$new()
n2$e$x <- 2
# n2$e$x does not affect n1$e$x
n1$e$x
## ------------------------------------------------------------------------
RC <- setRefClass("RC",
fields = list(x = 'ANY'),
methods = list(
getx = function() x,
setx = function(value) x <<- value
)
)
rc <- RC$new()
rc$setx(10)
rc$getx()
## ------------------------------------------------------------------------
NP <- R6Class("NP",
portable = FALSE,
public = list(
x = NA,
getx = function() x,
setx = function(value) x <<- value
)
)
np <- NP$new()
np$setx(10)
np$getx()
## ------------------------------------------------------------------------
P <- R6Class("P",
portable = TRUE, # This is default
public = list(
x = NA,
getx = function() self$x,
setx = function(value) self$x <- value
)
)
p <- P$new()
p$setx(10)
p$getx()
## ------------------------------------------------------------------------
Simple <- R6Class("Simple",
public = list(
x = 1,
getx = function() self$x
)
)
Simple$set("public", "getx2", function() self$x*2)
# To replace an existing member, use overwrite=TRUE
Simple$set("public", "x", 10, overwrite = TRUE)
s <- Simple$new()
s$x
s$getx2()
## ------------------------------------------------------------------------
# Create a locked class
Simple <- R6Class("Simple",
public = list(
x = 1,
getx = function() self$x
),
lock_class = TRUE
)
# This would result in an error
# Simple$set("public", "y", 2)
# Unlock the class
Simple$unlock()
# Now it works
Simple$set("public", "y", 2)
# Lock the class again
Simple$lock()
## ------------------------------------------------------------------------
Simple <- R6Class("Simple",
public = list(
x = 1,
getx = function() self$x
)
)
s <- Simple$new()
# Create a clone
s1 <- s$clone()
# Modify it
s1$x <- 2
s1$getx()
# Original is unaffected by changes to the clone
s$getx()
## ----clone-size, echo=FALSE----------------------------------------------
# Calculate size of clone method in this block.
Cloneable <- R6Class("Cloneable", cloneable = TRUE)
NonCloneable <- R6Class("NonCloneable", cloneable = FALSE)
c1 <- Cloneable$new()
c2 <- Cloneable$new()
# Bytes for each new cloneable object
cloneable_delta <- object_size(c1, c2) - object_size(c2)
nc1 <- NonCloneable$new()
nc2 <- NonCloneable$new()
# Bytes for each new noncloneable object
noncloneable_delta <- object_size(nc1, nc2) - object_size(nc2)
# Number of bytes used by each copy of clone method
additional_clone_method_bytes <- cloneable_delta - noncloneable_delta
additional_clone_method_bytes_str <- capture.output(print(additional_clone_method_bytes))
# Number of bytes used by first copy of a clone method
first_clone_method_bytes <- object_size(c1) - object_size(nc1)
# Need some trickery to get the nice output from pryr::print.bytes
first_clone_method_bytes_str <- capture.output(print(first_clone_method_bytes))
## ------------------------------------------------------------------------
Simple <- R6Class("Simple", public = list(x = 1))
Cloneable <- R6Class("Cloneable",
public = list(
s = NULL,
initialize = function() self$s <- Simple$new()
)
)
c1 <- Cloneable$new()
c2 <- c1$clone()
# Change c1's `s` field
c1$s$x <- 2
# c2's `s` is the same object, so it reflects the change
c2$s$x
## ------------------------------------------------------------------------
c3 <- c1$clone(deep = TRUE)
# Change c1's `s` field
c1$s$x <- 3
# c2's `s` is different
c3$s$x
## ------------------------------------------------------------------------
CloneEnv <- R6Class("CloneEnv",
public = list(
a = NULL,
b = NULL,
v = 1,
initialize = function() {
self$a <- new.env(parent = emptyenv())
self$b <- new.env(parent = emptyenv())
self$a$x <- 1
self$b$x <- 1
}
),
private = list(
deep_clone = function(name, value) {
# With x$clone(deep=TRUE) is called, the deep_clone gets invoked once for
# each field, with the name and value.
if (name == "a") {
# `a` is an environment, so use this quick way of copying
list2env(as.list.environment(value, all.names = TRUE),
parent = emptyenv())
} else {
# For all other fields, just return the value
value
}
}
)
)
c1 <- CloneEnv$new()
c2 <- c1$clone(deep = TRUE)
## ------------------------------------------------------------------------
# Modifying c1$a doesn't affect c2$a, because they're separate objects
c1$a$x <- 2
c2$a$x
# Modifying c1$b does affect c2$b, because they're the same object
c1$b$x <- 3
c2$b$x
# Modifying c1$v doesn't affect c2$v, because they're not reference objects
c1$v <- 4
c2$v
## ------------------------------------------------------------------------
PrettyCountingQueue <- R6Class("PrettyCountingQueue",
inherit = CountingQueue,
public = list(
print = function(...) {
cat("<PrettyCountingQueue> of ", self$get_total(), " elements\n", sep = "")
invisible(self)
}
)
)
## ------------------------------------------------------------------------
pq <- PrettyCountingQueue$new(1, 2, "foobar")
pq
## ------------------------------------------------------------------------
A <- R6Class("A", public = list(
initialize = function() {
reg.finalizer(self,
function(e) print("Finalizer has been called!"),
onexit = TRUE)
}
))
# Instantiate an object, but don't save a reference to it
A$new()
# Run something else to get rid of any references to the object, because the
# last returned value is saved in .Last.value
1+1
# Force immediate garbage collection (normally this will happen automatically
# from time to time)
gc()
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.