R6/ 0000755 0001762 0000144 00000000000 14753762272 010560 5 ustar ligges users R6/tests/ 0000755 0001762 0000144 00000000000 14752476063 011721 5 ustar ligges users R6/tests/manual/ 0000755 0001762 0000144 00000000000 14752476063 013176 5 ustar ligges users R6/tests/manual/README 0000644 0001762 0000144 00000000212 14752476063 014051 0 ustar ligges users The tests in this directory are somewhat invasive, so they must be run by hand,
and therefore are kept separate from the automated tests.
R6/tests/manual/encapsulation.R 0000644 0001762 0000144 00000010770 14752476063 016173 0 ustar ligges users library(lobstr)
library(testthat)
library(inline)
unlockEnvironment <- cfunction(signature(env = "environment"), body = '
#define FRAME_LOCK_MASK (1<<14)
#define FRAME_IS_LOCKED(e) (ENVFLAGS(e) & FRAME_LOCK_MASK)
#define UNLOCK_FRAME(e) SET_ENVFLAGS(e, ENVFLAGS(e) & (~ FRAME_LOCK_MASK))
if (TYPEOF(env) == NILSXP)
error("use of NULL environment is defunct");
if (TYPEOF(env) != ENVSXP)
error("not an environment");
UNLOCK_FRAME(env);
// Return TRUE if unlocked; FALSE otherwise
SEXP result = PROTECT( Rf_allocVector(LGLSXP, 1) );
LOGICAL(result)[0] = FRAME_IS_LOCKED(env) == 0;
UNPROTECT(1);
return result;
')
# To make sure these tests actually work:
# * Un-encapsulate one or more of the encapsulated functions.
# * load_all(), or install R6, restart R, then library(R6).
# * Run these tests. With the function(s) commented out, there should be an
# error. With the code restored to normal, there should be no errors.
test_that("R6 objects can be instantiated even when R6 isn't loaded", {
library(R6)
AC <- R6Class("AC",
portable = TRUE,
public = list(
x = 0,
initialize = function() {
self$inc_x()
private$inc_y()
self$incz
},
inc_x = function() self$x <- self$x + 1,
inc = function(val) val + 1,
pinc = function(val) private$priv_inc(val), # Call private inc method
gety = function() private$y,
z = 0
),
private = list(
y = 0,
inc_y = function() private$y <- private$y + 1,
priv_inc = function(val) val + 1
),
active = list(
incz = function() {
self$z <- self$z + 1
}
)
)
BC <- R6Class("BC",
portable = TRUE,
inherit = AC,
public = list(
inc_x = function() self$x <- self$x + 2,
inc = function(val) super$inc(val) + 20
),
private = list(
inc_y = function() private$y <- private$y + 2,
priv_inc = function(val) super$priv_inc(val) + 20
),
active = list(
incz = function() {
self$z <- self$z + 2
}
)
)
# Remove everything from the R6 namespace
r6ns <- .getNamespace('R6')
unlockEnvironment(r6ns)
rm(list = ls(r6ns), envir = r6ns)
# Also try unloading R6 namespace. Even this set of commands may not be enough
# to fully unload the R6 namespace environment, because AC and BC are children
# of the R6 namespace.
detach('package:R6', unload = TRUE)
expect_null(.getNamespace('R6'))
expect_error(as.environment('package:R6'))
expect_error(get('R6Class', inherits = TRUE))
B <- BC$new()
# Testing overrides
expect_identical(B$x, 2) # Public
expect_identical(B$gety(), 2) # Private
expect_identical(B$z, 2) # Active
# Calling superclass methods
expect_identical(B$inc(0), 21)
expect_identical(B$pinc(0), 21)
library(R6)
# Multi-level inheritance
CC <- R6Class("CC",
portable = TRUE,
inherit = BC,
public = list(
inc_x = function() self$x <- self$x + 3,
inc = function(val) super$inc(val) + 300
),
private = list(
inc_y = function() private$y <- private$y + 3,
priv_inc = function(val) super$priv_inc(val) + 300
),
active = list(
incz = function() {
self$z <- self$z + 3
}
)
)
# Remove everything from the R6 namespace
r6ns <- .getNamespace('R6')
unlockEnvironment(r6ns)
rm(list = ls(r6ns), envir = r6ns)
# Detach and unload R6, then run the tests as usual
detach('package:R6', unload = TRUE)
expect_null(.getNamespace('R6'))
expect_error(as.environment('package:R6'))
expect_error(get('R6Class', inherits = TRUE))
C <- CC$new()
# Testing overrides
expect_identical(C$x, 3) # Public
expect_identical(C$gety(), 3) # Private
expect_identical(C$z, 3) # Active
# Calling superclass methods (two levels)
expect_identical(C$inc(0), 321)
expect_identical(C$pinc(0), 321)
# Classes
expect_identical(class(C), c("CC", "BC", "AC", "R6"))
})
# Encapsulate R6 in new() =======================
# This set of tests requires restarting R
library(R6)
AC <- R6Class("AC",
portable = FALSE,
public = list(
x = 1,
getx = function() self$x
)
)
BC <- R6Class("BC",
portable = FALSE,
inherit = AC,
public = list(
x = 2,
getx = function() self$x
)
)
save(AC, BC, file = 'test.rda')
#### Restart R ####
library(testthat)
load('test.rda')
# R6 will be loaded
expect_true("R6" %in% loadedNamespaces())
A <- AC$new()
B <- BC$new()
expect_identical(A$getx(), 1)
expect_identical(B$getx(), 2)
# Clean up
unlink('test.rda')
R6/tests/manual/test-inheritance.R 0000644 0001762 0000144 00000014113 14752476063 016567 0 ustar ligges users library(testthat)
## Helper functions to create a new package, with some
## R code, and install it temporarily
install_quietly <- TRUE
with_wd <- function(dir, expr) {
wd <- getwd()
on.exit(setwd(wd))
setwd(dir)
eval(substitute(expr), envir = parent.frame())
}
build_pkg <- function(path, pkg_file = NULL) {
if (!file.exists(path)) stop("path does not exist")
pkg_name <- basename(path)
if (is.null(pkg_file)) {
pkg_file <- file.path(dirname(path), paste0(pkg_name, "_1.0.tar.gz"))
}
with_wd(dirname(path),
tar(basename(pkg_file), pkg_name, compression = "gzip"))
pkg_file
}
install_tmp_pkg <- function(..., pkg_name, lib_dir, imports = "R6") {
if (!file.exists(lib_dir)) stop("lib_dir does not exist")
if (!is.character(pkg_name) || length(pkg_name) != 1) {
stop("pkg_name is not a string")
}
## Create a directory that will contain the source package
src_dir <- tempfile()
on.exit(try(unlink(src_dir, recursive = TRUE), silent = TRUE), add = TRUE)
dir.create(src_dir)
## Create source package, need a non-empty environment,
## otherwise package.skeleton fails
tmp_env <- new.env()
assign("f", function(x) x, envir = tmp_env)
suppressMessages(package.skeleton(pkg_name, path = src_dir,
envir = tmp_env))
pkg_dir <- file.path(src_dir, pkg_name)
## Make it installable: remove man, add R6 dependency
unlink(file.path(pkg_dir, "man"), recursive = TRUE)
cat("Imports: ", paste(imports, collapse = ", "), "\n",
file = file.path(pkg_dir, "DESCRIPTION"), append = TRUE)
cat(paste0("import(", imports, ")"), sep="\n",
file = file.path(pkg_dir, "NAMESPACE"), append = TRUE)
## Put the code in it, dput is noisy, so we need to redirect it to
## temporary file
exprs <- list(...)
unlink(file.path(pkg_dir, "R"), recursive = TRUE)
dir.create(file.path(pkg_dir, "R"))
code_file <- file.path(pkg_dir, "R", "code.R")
tmp_file <- tempfile()
on.exit(try(unlink(tmp_file), silent = TRUE), add = TRUE)
sapply(exprs, function(x)
cat(deparse(dput(x, file = tmp_file)),
file = code_file, append = TRUE, "\n", sep="\n"))
## Build it
pkg_file <- build_pkg(pkg_dir)
## Install it into the supplied lib_dir
install.packages(pkg_file, lib = lib_dir, repos = NULL, type = "source",
quiet = install_quietly)
}
with_libpath <- function(lib_path, ...) {
cur_lib_path <- .libPaths()
on.exit(.libPaths(cur_lib_path), add = TRUE)
.libPaths(c(lib_path, cur_lib_path))
exprs <- c(as.list(match.call(expand.dots = FALSE)$...))
sapply(exprs, eval, envir = parent.frame())
}
## Each expression in ... is put in a package, that
## is installed and loaded. The package name is given by
## argument name. The packages will be installed in lib_dir,
load_tmp_pkgs <- function(..., lib_dir = tempfile(), imports = "R6") {
if (!file.exists(lib_dir)) dir.create(lib_dir)
exprs <- c(as.list(match.call(expand.dots = FALSE)$...))
for (i in seq_along(exprs)) {
expr <- exprs[[i]]
name <- names(exprs)[i]
install_tmp_pkg(expr, pkg_name = name,
lib_dir = lib_dir, imports = imports)
## Unload everything if an error happens
on.exit(try(unloadNamespace(name), silent = TRUE), add = TRUE)
with_libpath(lib_dir, suppressMessages(library(name, quietly = TRUE,
character.only = TRUE)))
on.exit()
}
invisible(NULL)
}
test_that("inheritance works across packages", {
## Temporary lib_dir
lib_dir <- tempfile()
on.exit(try(unlink(lib_dir, recursive = TRUE), silent = TRUE),
add = TRUE)
on.exit(unloadNamespace("R6testB"), add = TRUE)
on.exit(unloadNamespace("R6testA"), add = TRUE)
## Make sure that we get the latest versions of them
try(unloadNamespace("R6testB"), silent = TRUE)
try(unloadNamespace("R6testA"), silent = TRUE)
load_tmp_pkgs(lib_dir = lib_dir,
## Code to put in package 'R6testA'
R6testA = {
AC <- R6Class(
public = list(
x = 1
)
)
},
## Code to put in package 'R6testB'
R6testB = {
BC <- R6Class(
inherit = R6testA::AC,
public = list(
y = 2
)
)
}
)
## Now ready for the tests
B <- BC$new()
expect_equal(B$x, 1)
expect_equal(B$y, 2)
})
test_that("more inheritance", {
## Temporary lib_dir
lib_dir <- tempfile()
on.exit(try(unlink(lib_dir, recursive = TRUE), silent = TRUE), add = TRUE)
on.exit(unloadNamespace("pkgB"), add = TRUE)
on.exit(unloadNamespace("pkgA"), add = TRUE)
## Make sure that we get the latest versions of them
try(unloadNamespace("pkgB"), silent = TRUE)
try(unloadNamespace("pkgA"), silent = TRUE)
load_tmp_pkgs(lib_dir = lib_dir,
pkgA = {
funA <- function() {
message("Called funA in pkgA 1.0")
}
AC <- R6Class("AC",
public = list(
versionString = "pkgA 1.0",
fun = function() {
message("This object was created in pkgA 1.0")
message(paste0("The object has versionString ",
self$versionString))
funA()
}
)
)
}
)
load_tmp_pkgs(lib_dir = lib_dir, imports = "pkgA",
pkgB = {
B <- pkgA::AC$new()
}
)
expect_message(B$fun(), "created in pkgA 1.0")
expect_message(B$fun(), "versionString pkgA 1.0")
expect_message(B$fun(), "Called funA in pkgA 1.0")
unloadNamespace("pkgB")
unloadNamespace("pkgA")
load_tmp_pkgs(lib_dir = lib_dir,
pkgA = {
funA <- function() {
message("Called funA in pkgA 2.0")
}
AC <- R6Class("AC",
public = list(
versionString = "pkgA 2.0",
fun = function() {
message("This object was created in pkgA 2.0")
message(paste0("The object has versionString ",
self$versionString))
funA()
}
)
)
}
)
with_libpath(lib_dir, library(pkgB))
expect_message(B$fun(), "created in pkgA 1.0")
expect_message(B$fun(), "versionString pkgA 1.0")
expect_message(B$fun(), "Called funA in pkgA 2.0")
})
R6/tests/testthat/ 0000755 0001762 0000144 00000000000 14753762272 013562 5 ustar ligges users R6/tests/testthat/test-aslist.R 0000644 0001762 0000144 00000001216 14752476063 016160 0 ustar ligges users test_that("list of public members is generated as expected by as.list.R6 method", {
Person <- R6Class("Person",
public = list(
name = NULL,
hair = NULL,
initialize = function(name = NA, hair = NA) {
self$name <- name
self$hair <- hair
},
set_hair = function(val) {
self$hair <- val
}
)
)
ann <- Person$new("Ann", "black")
annList <- as.list(ann)
expect_type(annList, "list")
expect_equal(
names(annList),
c(".__enclos_env__", "hair", "name", "clone", "set_hair", "initialize")
)
expect_equal(annList$hair, ann$hair)
expect_equal(annList$name, ann$name)
})
R6/tests/testthat/test-nonportable.R 0000644 0001762 0000144 00000012231 14752476063 017203 0 ustar ligges users test_that("initialization", {
AC <- R6Class("AC",
portable = FALSE,
public = list(
x = 1,
initialize = function(x, y) {
self$x <- getx() + x # Assign to self; also access a method
private$y <- y # Assign to private
},
getx = function() x,
gety = function() private$y
),
private = list(
y = 2
)
)
A <- AC$new(2, 3)
expect_identical(A$x, 3)
expect_identical(A$gety(), 3)
# No initialize method: throw error if arguments are passed in
AC <- R6Class("AC", portable = FALSE, public = list(x = 1))
expect_error(AC$new(3))
})
test_that("empty members and methods are allowed", {
# No initialize method: throw error if arguments are passed in
AC <- R6Class("AC", portable = FALSE)
expect_no_error(AC$new())
})
test_that("Private members are private, and self/private environments", {
AC <- R6Class("AC",
portable = FALSE,
public = list(
x = 1,
gety = function() private$y,
gety2 = function() y,
getx = function() self$x,
getx2 = function() x,
getx3 = function() getx_priv3(),
getx4 = function() getx_priv4()
),
private = list(
y = 2,
getx_priv3 = function() self$x,
getx_priv4 = function() x
)
)
A <- AC$new()
# Environment structure
expect_identical(A$self, A)
expect_identical(A$private, parent.env(A))
# Enclosing env for fublic and private methods is the public env
expect_identical(A, environment(A$getx))
expect_identical(A, environment(A$private$getx_priv3))
# Behavioral tests
expect_identical(A$x, 1)
expect_null(A$y)
expect_error(A$getx_priv3())
expect_identical(A$gety(), 2) # Explicit access: private$y
expect_identical(A$gety2(), 2) # Implicit access: y
expect_identical(A$getx(), 1) # Explicit access: self$x
expect_identical(A$getx2(), 1) # Implicit access: x
expect_identical(A$getx3(), 1) # Call private method, which has explicit: self$x
expect_identical(A$getx4(), 1) # Call private method, which has implicit: x
})
test_that("Active bindings work", {
AC <- R6Class("AC",
portable = FALSE,
public = list(
x = 5
),
active = list(
x2 = function(value) {
if (missing(value)) return(x * 2)
else x <<- value/2
}
)
)
A <- AC$new()
expect_identical(A$x2, 10)
A$x <- 20
expect_identical(A$x2, 40)
A$x2 <- 60
expect_identical(A$x2, 60)
expect_identical(A$x, 30)
})
test_that("Locking objects", {
AC <- R6Class("AC",
portable = FALSE,
public = list(x = 1, getx = function() x),
private = list(y = 2, gety = function() y),
lock_objects = TRUE
)
A <- AC$new()
# Can modify fields
expect_no_error(A$x <- 5)
expect_identical(A$x, 5)
expect_no_error(A$private$y <- 5)
expect_identical(A$private$y, 5)
# Can't modify methods
expect_error(A$getx <- function() 1)
expect_error(A$gety <- function() 2)
# Can't add members
expect_error(A$z <- 1)
expect_error(A$private$z <- 1)
# Not locked
AC <- R6Class("AC",
portable = FALSE,
public = list(x = 1, getx = function() x),
private = list(y = 2, gety = function() y),
lock_objects = FALSE
)
A <- AC$new()
# Can modify fields
expect_no_error(A$x <- 5)
expect_identical(A$x, 5)
expect_no_error(A$private$y <- 5)
expect_identical(A$private$y, 5)
# Can't modify methods
expect_error(A$getx <- function() 1)
expect_error(A$private$gety <- function() 2)
# Can add members
expect_no_error(A$z <- 1)
expect_identical(A$z, 1)
expect_no_error(A$private$z <- 1)
expect_identical(A$private$z, 1)
})
test_that("Validity checks on creation", {
fun <- function() 1 # Dummy function for tests
# All arguments must be named
expect_error(R6Class("AC", public = list(1)))
expect_error(R6Class("AC", private = list(1)))
expect_error(R6Class("AC", active = list(fun)))
# Names can't be duplicated
expect_error(R6Class("AC", public = list(a=1, a=2)))
expect_error(R6Class("AC", public = list(a=1), private = list(a=1)))
expect_error(R6Class("AC", private = list(a=1), active = list(a=fun)))
# Reserved names
expect_error(R6Class("AC", public = list(self = 1)))
expect_error(R6Class("AC", private = list(private = 1)))
expect_error(R6Class("AC", active = list(super = 1)))
# `initialize` only allowed in public
expect_error(R6Class("AC", private = list(initialize = fun)))
expect_error(R6Class("AC", active = list(initialize = fun)))
})
test_that("default print method has a trailing newline", {
## This is kind of hackish, because both capture.output and
## expect_output drop the trailing newline. This function
## does not work in the general case, but it is good enough
## for this test.
expect_output_n <- function(object) {
tmp <- tempfile()
on.exit(unlink(tmp))
sink(tmp)
print(object)
sink(NULL)
output <- readChar(tmp, nchars = 10000)
last_char <- substr(output, nchar(output), nchar(output))
expect_identical(last_char, "\n")
}
AC <- R6Class("AC")
expect_output_n(print(AC))
A <- AC$new()
expect_output_n(print(A))
AC <- R6Class("AC", private = list( x = 2 ))
expect_output_n(print(AC))
A <- AC$new()
expect_output_n(print(A))
})
R6/tests/testthat/test-set.R 0000644 0001762 0000144 00000005672 14752476063 015466 0 ustar ligges users test_that("Setting values set values on generator", {
AC <- R6Class("AC",
public = list(
x = 1,
getxyz = function() self$x + private$y + private$z()
),
private = list(
y = 2,
z = function() 3
),
active = list(
x2 = function(value) {
if (missing(value)) return(self$x * 2)
else self$x <<- value/2
}
)
)
# Can set new names
AC$set("public", "nx", 10)
AC$set("public", "ngetxyz", function() self$nx + private$ny + private$nz())
AC$set("private", "ny", 20)
AC$set("private", "nz", function() 30)
AC$set("active", "nx2", function(value) {
if (missing(value)) return(self$nx * 2)
else self$nx <<- value/2
})
A <- AC$new()
expect_identical(A$nx, 10)
expect_identical(A$ngetxyz(), 60)
expect_identical(A$nx2, 20)
# Can't set existing names
expect_error(AC$set("public", "x", 99))
expect_error(AC$set("public", "getxyz", function() 99))
expect_error(AC$set("private", "y", 99))
expect_error(AC$set("private", "z", function() 99))
expect_error(AC$set("active", "x2", function(value) 99))
# Can't set existing names in different group
expect_error(AC$set("private", "x", 99))
expect_error(AC$set("private", "getxyz", function() 99))
expect_error(AC$set("active", "y", 99))
expect_error(AC$set("public", "z", function() 99))
expect_error(AC$set("private", "x2", function(value) 99))
# Can set existing names if overwrite = TRUE
AC$set("public", "x", 99, overwrite = TRUE)
AC$set("public", "getxyz", function() 99, overwrite = TRUE)
AC$set("private", "y", 99, overwrite = TRUE)
AC$set("private", "z", function() 99, overwrite = TRUE)
AC$set("active", "x2", function(value) 99, overwrite = TRUE)
# Can't set existing names in different group, even if overwrite = TRUE
expect_error(AC$set("private", "x", 99, overwrite = TRUE))
expect_error(AC$set("private", "getxyz", function() 99, overwrite = TRUE))
expect_error(AC$set("active", "y", 99, overwrite = TRUE))
expect_error(AC$set("public", "z", function() 99, overwrite = TRUE))
expect_error(AC$set("private", "x2", function(value) 99, overwrite = TRUE))
})
test_that("Setting values with empty public or private", {
AC <- R6Class("AC",
public = list(),
private = list()
)
AC$set("public", "x", 1)
AC$set("private", "y", 1)
AC$set("public", "gety", function() private$y)
a <- AC$new()
expect_identical(a$x, 1)
expect_identical(a$gety(), 1)
})
test_that("Locked class", {
AC <- R6Class("AC", lock_class = TRUE)
expect_error(AC$set("public", "x", 1))
expect_error(AC$set("private", "x", 1))
expect_true(AC$is_locked())
AC$unlock()
expect_false(AC$is_locked())
AC$set("public", "x", 1)
AC$lock()
expect_error(AC$set("public", "x", 2))
})
test_that("Assigning NULL values", {
AC <- R6Class("AC",
public = list(),
private = list()
)
AC$set("public", "x", NULL)
a <- AC$new()
expect_true("x" %in% names(a))
expect_identical(a$x, NULL)
})
R6/tests/testthat/test-s3-methods.R 0000644 0001762 0000144 00000002324 14752476063 016650 0 ustar ligges users test_that("`$` and `[[` methods don't interfere with R6 operations", {
# Make sure that these method aren't used anywhere in internal R6 code
`$.AC` <- function(x, name) stop("Attempted to use `$.AC`")
`[[.AC` <- function(x, name) stop("Attempted to use `[[.AC`")
`$<-.AC` <- function(x, name, value) stop("Attempted to use `$<-.AC`")
`[[<-.AC` <- function(x, name, value) stop("Attempted to use `[[<-.AC`")
AC <- R6Class("AC",
public = list(
x = 1,
gety = function() private$y
),
private = list(
y = 2,
y2 = function() y * 2
),
active = list(
z = function(value) 3
)
)
expect_no_error(a <- AC$new())
expect_no_error(b <- .subset2(a, "clone")())
})
test_that("Cloning avoids names() S3 method", {
# A names() method can be defined for a class. We need to avoid it during
# initialization and cloning -- need to use ls() instead, which does not get
# dispatched based on class.
names.A <- function(x) stop("Oops")
A <- R6Class("A",
public = list(x = 1),
private = list(
deep_clone = function(name, value) value
)
)
expect_silent(a <- A$new())
expect_silent(a1 <- a$clone())
expect_silent(a2 <- a$clone(deep = TRUE))
})
R6/tests/testthat/helper.R 0000644 0001762 0000144 00000000311 14752476063 015156 0 ustar ligges users expect_no_error <- function(expr) {
err <- FALSE
tryCatch(force(expr),
error = function(e) {
err <<- TRUE
}
)
expect(!err, "Expected no error, but had error.")
invisible(NULL)
} R6/tests/testthat/test-portable.R 0000644 0001762 0000144 00000011511 14752476063 016470 0 ustar ligges users test_that("initialization", {
AC <- R6Class("AC",
portable = TRUE,
public = list(
x = 1,
initialize = function(x, y) {
self$x <- self$getx() + x # Assign to self; also access a method
private$y <- y # Assign to private
},
getx = function() self$x,
gety = function() private$y
),
private = list(
y = 2
)
)
A <- AC$new(2, 3)
expect_identical(A$x, 3)
expect_identical(A$gety(), 3)
# No initialize method: throw error if arguments are passed in
AC <- R6Class("AC", portable = TRUE, public = list(x = 1))
expect_error(AC$new(3))
})
test_that("empty members and methods are allowed", {
# No initialize method: throw error if arguments are passed in
AC <- R6Class("AC", portable = TRUE)
expect_no_error(AC$new())
})
test_that("Private members are private, and self/private environments", {
AC <- R6Class("AC",
portable = TRUE,
public = list(
x = 1,
gety = function() private$y,
getx = function() self$x,
getx2 = function() private$getx_priv(),
getself = function() self,
getprivate = function() private
),
private = list(
y = 2,
getx_priv = function() self$x
)
)
A <- AC$new()
# Environment structure
expect_identical(A$getself(), A)
expect_identical(parent.env(A), emptyenv())
# The private binding environment contains private fields
private_bind_env <- A$getprivate()
expect_identical(ls(private_bind_env), c("getx_priv", "y"))
expect_identical(parent.env(private_bind_env), emptyenv())
# Eval environment for public methods
eval_env <- environment(A$getx)
expect_identical(parent.env(eval_env), environment())
expect_identical(eval_env$self, A)
expect_identical(eval_env$private, A$getprivate())
# Eval environment for private methods should be the same
expect_identical(eval_env, environment(A$getprivate()$getx_priv))
# Behavioral tests
expect_identical(A$x, 1)
expect_null(A$y)
expect_null(A$getx_foo)
expect_identical(A$gety(), 2) # Explicit access: private$y
expect_identical(A$getx(), 1) # Explicit access: self$x
expect_identical(A$getx2(), 1) # Indirect access: private$getx_priv()
})
test_that("Private methods exist even when no private fields", {
AC <- R6Class("AC",
portable = TRUE,
public = list(
x = 1,
getx = function() self$x,
getx2 = function() private$getx_priv(),
getself = function() self,
getprivate = function() private
),
private = list(
getx_priv = function() self$x
)
)
A <- AC$new()
# The private binding environment contains private fields
private_bind_env <- A$getprivate()
expect_identical(ls(private_bind_env), "getx_priv")
expect_identical(parent.env(private_bind_env), emptyenv())
})
test_that("Active bindings work", {
AC <- R6Class("AC",
portable = TRUE,
public = list(
x = 5
),
active = list(
x2 = function(value) {
if (missing(value)) return(self$x * 2)
else self$x <- value/2
},
sqrt_of_x = function(value) {
if (!missing(value))
# In "setter" role
stop("Sorry this is a read-only variable.")
else {
# In "getter" role
if (self$x < 0) stop("The requested value is not available.")
else sqrt(self$x)
}
}
)
)
A <- AC$new()
expect_identical(A$x2, 10)
A$x <- 20
expect_identical(A$x2, 40)
A$x2 <- 60
expect_identical(A$x2, 60)
expect_identical(A$x, 30)
A$x <- -2
expect_error(A$sqrt_of_x)
# print does not throw an error trying to read
# the active binding variables
muted_print <- function(x) capture.output(print(x))
expect_no_error(muted_print(A))
})
test_that("Locking works", {
AC <- R6Class("AC",
portable = FALSE,
public = list(x = 1, getx = function() self$x),
private = list(y = 2, gety = function() self$y),
lock_objects = TRUE
)
A <- AC$new()
# Can modify fields
expect_no_error(A$x <- 5)
expect_identical(A$x, 5)
expect_no_error(A$private$y <- 5)
expect_identical(A$private$y, 5)
# Can't modify methods
expect_error(A$getx <- function() 1)
expect_error(A$gety <- function() 2)
# Can't add members
expect_error(A$z <- 1)
expect_error(A$private$z <- 1)
# Not locked
AC <- R6Class("AC",
portable = FALSE,
public = list(x = 1, getx = function() x),
private = list(y = 2, gety = function() y),
lock_objects = FALSE
)
A <- AC$new()
# Can modify fields
expect_no_error(A$x <- 5)
expect_identical(A$x, 5)
expect_no_error(A$private$y <- 5)
expect_identical(A$private$y, 5)
# Can't modify methods
expect_error(A$getx <- function() 1)
expect_error(A$private$gety <- function() 2)
# Can add members
expect_no_error(A$z <- 1)
expect_identical(A$z, 1)
expect_no_error(A$private$z <- 1)
expect_identical(A$private$z, 1)
})
R6/tests/testthat/test-cloning-inheritance.R 0000644 0001762 0000144 00000002465 14752476063 020610 0 ustar ligges users test_that("Subclass can override superclass' cloneable property", {
# superclass cloneable ---------------------
Creature <- R6Class("Creature", cloneable = TRUE)
Sheep <- R6Class("Sheep", inherit = Creature, cloneable = TRUE)
expect_message(sheep <- Sheep$new(), NA)
expect_s3_class(sheep$clone(), "Sheep")
expect_true("clone" %in% names(Creature$public_methods))
Human <- R6Class("Human", inherit = Creature, cloneable = FALSE)
expect_message(human <- Human$new(), NA)
expect_error(human$clone(), "attempt to apply non-function")
expect_true("clone" %in% names(Creature$public_methods))
# superclass non-cloneable ---------------------
Creature <- R6Class("Creature", cloneable = FALSE)
Sheep <- R6Class("Sheep", inherit = Creature, cloneable = TRUE)
expect_message(sheep <- Sheep$new(), "Superclass Creature has cloneable=FALSE, but subclass Sheep has cloneable=TRUE.")
expect_error(sheep$clone(), "attempt to apply non-function")
# Make sure that the superclass wasn't inadvertantly modified.
expect_false("clone" %in% names(Creature$public_methods))
Human <- R6Class("Human", inherit = Creature, cloneable = FALSE)
expect_message(human <- Human$new(), NA)
expect_error(human$clone(), "attempt to apply non-function")
expect_false("clone" %in% names(Creature$public_methods))
})
R6/tests/testthat/test-portable-inheritance.R 0000644 0001762 0000144 00000025025 14752476063 020764 0 ustar ligges users test_that("Inheritance", {
AC <- R6Class("AC",
portable = TRUE,
public = list(
x = 0,
z = 0,
initialize = function(x) self$x <- x,
getx = function() self$x,
getx2 = function() self$x*2,
getprivateA = function() private
),
private = list(
getz = function() self$z,
getz2 = function() self$z*2
),
active = list(
x2 = function(value) {
if (missing(value)) return(self$x * 2)
else self$x <- value/2
},
x3 = function(value) {
if (missing(value)) return(self$x * 3)
else self$x <- value/3
}
)
)
BC <- R6Class("BC",
portable = TRUE,
inherit = AC,
public = list(
y = 0,
z = 3,
initialize = function(x, y) {
super$initialize(x)
self$y <- y
},
getx = function() self$x + 10,
getprivateB = function() private
),
private = list(
getz = function() self$z + 10
),
active = list(
x2 = function(value) {
if (missing(value)) return(self$x + 2)
else self$x <- value-2
}
)
)
B <- BC$new(1, 2)
# Environment checks
eval_env <- environment(B$getx)
super_bind_env <- eval_env$super
super_eval_env <- environment(super_bind_env$getx)
expect_identical(parent.env(super_bind_env), emptyenv())
expect_identical(parent.env(super_eval_env), environment())
expect_identical(super_eval_env$self, B)
expect_identical(super_eval_env$private, B$getprivateA())
expect_identical(B$getprivateA(), B$getprivateB())
# Overridden public method
expect_identical(eval_env, environment(B$getx))
# Inherited public method
environment(B$getx2)
expect_identical(B, environment(B$getx2)$self)
# Overridden private method
expect_identical(eval_env, environment(B$getprivateA()$getz))
# Inherited private method - should have same eval env as inherited public
expect_identical(environment(B$getx2), environment(B$getprivateA()$getz2))
# Behavioral tests
# Overriding literals
expect_identical(B$x, 1)
expect_identical(B$y, 2)
expect_identical(B$z, 3) # Subclass value overrides superclass value
# Methods
expect_identical(B$getx(), 11) # Overridden public method
expect_identical(B$getx2(), 2) # Inherited public method
expect_identical(B$getprivateA()$getz(), 13) # Overriden private method
expect_identical(B$getprivateA()$getz2(), 6) # Inherited private method
# Active bindings
expect_identical(B$x2, 3) # Overridden
expect_identical(B$x3, 3) # Inherited
# Classes
expect_identical(class(B), c("BC", "AC", "R6"))
})
test_that("Inheritance: superclass methods", {
AC <- R6Class("AC",
portable = TRUE,
public = list(
x = 0,
initialize = function() {
self$inc_x()
private$inc_y()
self$incz
},
inc_x = function() self$x <- self$x + 1,
inc = function(val) val + 1,
pinc = function(val) private$priv_inc(val), # Call private inc method
gety = function() private$y,
z = 0
),
private = list(
y = 0,
inc_y = function() private$y <- private$y + 1,
priv_inc = function(val) val + 1
),
active = list(
incz = function(value) {
self$z <- z + 1
}
)
)
BC <- R6Class("BC",
portable = TRUE,
inherit = AC,
public = list(
inc_x = function() self$x <- self$x + 2,
inc = function(val) super$inc(val) + 20
),
private = list(
inc_y = function() private$y <- private$y + 2,
priv_inc = function(val) super$priv_inc(val) + 20
),
active = list(
incz = function(value) {
self$z <- self$z + 2
}
)
)
B <- BC$new()
# Testing overrides
expect_identical(B$x, 2) # Public
expect_identical(B$gety(), 2) # Private
expect_identical(B$z, 2) # Active
# Calling superclass methods
expect_identical(B$inc(0), 21)
expect_identical(B$pinc(0), 21)
# Multi-level inheritance
CC <- R6Class("CC",
portable = TRUE,
inherit = BC,
public = list(
inc_x = function() self$x <- self$x + 3,
inc = function(val) super$inc(val) + 300
),
private = list(
inc_y = function() private$y <- private$y + 3,
priv_inc = function(val) super$priv_inc(val) + 300
),
active = list(
incz = function(value) {
self$z <- self$z + 3
}
)
)
C <- CC$new()
# Testing overrides
expect_identical(C$x, 3) # Public
expect_identical(C$gety(), 3) # Private
expect_identical(C$z, 3) # Active
# Calling superclass methods (two levels)
expect_identical(C$inc(0), 321)
expect_identical(C$pinc(0), 321)
# Classes
expect_identical(class(C), c("CC", "BC", "AC", "R6"))
})
test_that("Inheritance: enclosing environments for super$ methods", {
encA <- new.env()
encB <- new.env()
encC <- new.env()
encA$n <- 1
encB$n <- 20
encC$n <- 300
AC <- R6Class("AC",
portable = TRUE,
parent_env = encA,
public = list(
x = 0,
initialize = function() {
self$x <- self$get_n()
},
get_n = function() n,
priv_get_n = function(val) private$get_n_priv()
),
private = list(
get_n_priv = function() n
),
active = list(
active_get_n = function() n
)
)
A <- AC$new()
expect_identical(A$x, 1)
expect_identical(A$get_n(), 1)
expect_identical(A$priv_get_n(), 1)
expect_identical(A$active_get_n, 1)
BC <- R6Class("BC",
portable = TRUE,
parent_env = encB,
inherit = AC,
public = list(
x = 0,
initialize = function() {
super$initialize()
},
get_n = function() n + super$get_n(),
priv_get_n = function(val) private$get_n_priv()
),
private = list(
get_n_priv = function() n + super$get_n_priv()
),
active = list(
active_get_n = function() n + super$active_get_n
)
)
B <- BC$new()
expect_identical(B$x, 21)
expect_identical(B$get_n(), 21)
expect_identical(B$priv_get_n(), 21)
expect_identical(B$active_get_n, 21)
CC <- R6Class("CC",
portable = TRUE,
parent_env = encC,
inherit = BC,
public = list(
x = 0,
initialize = function() {
super$initialize()
},
get_n = function() n + super$get_n(),
priv_get_n = function(val) private$get_n_priv()
),
private = list(
get_n_priv = function() n + super$get_n_priv()
),
active = list(
active_get_n = function() n + super$active_get_n
)
)
C <- CC$new()
expect_identical(C$x, 321)
expect_identical(C$get_n(), 321)
expect_identical(C$priv_get_n(), 321)
expect_identical(C$active_get_n, 321)
})
test_that("Inheritance: enclosing environments for inherited methods", {
encA <- new.env()
encB <- new.env()
encC <- new.env()
encA$n <- 1
encB$n <- 20
encC$n <- 300
AC <- R6Class("AC",
portable = TRUE,
parent_env = encA,
public = list(
get_n = function() n
)
)
A <- AC$new()
expect_identical(A$get_n(), 1)
BC <- R6Class("BC",
portable = TRUE,
parent_env = encB,
inherit = AC
)
B <- BC$new()
# Since this inherits A's get_n() method, it should also inherit the
# environment in which get_n() runs. This is necessary for inherited methods
# to find methods from the correct namespace.
expect_identical(B$get_n(), 1)
CC <- R6Class("CC",
portable = TRUE,
parent_env = encC,
inherit = BC,
public = list(
get_n = function() n + super$get_n()
)
)
C <- CC$new()
# When this calls super$get_n(), it should get B's version of get_n(), which
# should in turn run in A's environment, returning 1. Add C's value of n, and
# the total is 301.
expect_identical(C$get_n(), 301)
})
test_that("Inheritance hierarchy for super$ methods", {
AC <- R6Class("AC", portable = TRUE,
public = list(n = function() 0 + 1)
)
expect_identical(AC$new()$n(), 1)
BC <- R6Class("BC", portable = TRUE,
public = list(n = function() super$n() + 10),
inherit = AC
)
expect_identical(BC$new()$n(), 11)
CC <- R6Class("CC", portable = TRUE,
inherit = BC
)
# This should equal 11 because it inherits BC's n(), which adds 1 to AC's n()
expect_identical(CC$new()$n(), 11)
# Skipping one level of inheritance ---------------------------------
AC <- R6Class("AC", portable = TRUE,
public = list(n = function() 0 + 1)
)
expect_identical(AC$new()$n(), 1)
BC <- R6Class("BC", portable = TRUE,
inherit = AC
)
expect_identical(BC$new()$n(), 1)
CC <- R6Class("CC", portable = TRUE,
public = list(n = function() super$n() + 100),
inherit = BC
)
# This should equal 101 because BC inherits AC's n()
expect_identical(CC$new()$n(), 101)
DC <- R6Class("DC", portable = TRUE,
inherit = CC
)
# This should equal 101 because DC inherits CC's n(), and BC inherits AC's n()
expect_identical(DC$new()$n(), 101)
# Skipping two level of inheritance ---------------------------------
AC <- R6Class("AC", portable = TRUE,
public = list(n = function() 0 + 1)
)
expect_identical(AC$new()$n(), 1)
BC <- R6Class("BC", portable = TRUE, inherit = AC)
expect_identical(BC$new()$n(), 1)
CC <- R6Class("CC", portable = TRUE, inherit = BC)
expect_identical(CC$new()$n(), 1)
})
test_that("sub and superclass must both be portable or non-portable", {
AC <- R6Class("AC", portable = FALSE, public = list(x=1))
BC <- R6Class("BC", portable = TRUE, inherit = AC)
expect_error(BC$new())
AC <- R6Class("AC", portable = TRUE, public = list(x=1))
BC <- R6Class("BC", portable = FALSE, inherit = AC)
expect_error(BC$new())
})
test_that("Inheritance is dynamic", {
AC <- R6Class("AC",
public = list(x = 1, initialize = function() self$x <<- self$x + 10)
)
BC <- R6Class("BC", inherit = AC)
expect_identical(BC$new()$x, 11)
AC <- R6Class("AC",
public = list(x = 2, initialize = function() self$x <<- self$x + 20)
)
expect_identical(BC$new()$x, 22)
# BC doesn't contain AC, and it has less stuff in it, so it should be smaller
# than AC.
if (requireNamespace("lobstr", quietly = TRUE)) {
expect_true(lobstr::obj_size(BC) < lobstr::obj_size(AC))
}
})
test_that("Private env is created when all private members are inherited", {
# Private contains fields only
AC <- R6Class("AC",
public = list(getx = function() private$x),
private = list(x = 1)
)
BC <- R6Class("BC", inherit = AC)
expect_identical(BC$new()$getx(), 1)
# Private contains functions only
AC <- R6Class("AC",
public = list(getx = function() private$x()),
private = list(x = function() 1)
)
BC <- R6Class("BC", inherit = AC)
expect_identical(BC$new()$getx(), 1)
})
R6/tests/testthat/test-clone.R 0000644 0001762 0000144 00000101617 14752476063 015767 0 ustar ligges users test_that("Can't use reserved name 'clone'", {
expect_error(R6Class("AC", public = list(clone = function() NULL)))
expect_error(R6Class("AC", private = list(clone = function() NULL)))
expect_error(R6Class("AC", active = list(clone = function() NULL)))
})
test_that("Can disable cloning", {
AC <- R6Class("AC", public = list(x = 1), cloneable = FALSE)
a <- AC$new()
expect_null(a$clone)
})
test_that("Cloning portable objects with public only", {
parenv <- new.env()
AC <- R6Class("AC",
portable = TRUE,
public = list(
x = 1,
getx = function() self$x
),
parent_env = parenv
)
# Behavioral tests
a <- AC$new()
b <- a$clone()
b$x <- 2
expect_identical(a$getx(), 1)
expect_identical(b$getx(), 2)
# Enclosing environment for methods
a_enclos_env <- environment(a$getx)
b_enclos_env <- environment(b$getx)
# self points to the object (public binding env)
expect_identical(a_enclos_env$self, a)
expect_identical(b_enclos_env$self, b)
# Parent of enclosing env should be class's parent_env
expect_identical(parent.env(a_enclos_env), parenv)
expect_identical(parent.env(b_enclos_env), parenv)
# Enclosing env only contains self
expect_identical(ls(a_enclos_env), "self")
expect_identical(ls(b_enclos_env), "self")
# Parent of binding env is emptyenv(), for portable classes
expect_identical(parent.env(a), emptyenv())
expect_identical(parent.env(b), emptyenv())
# Cloning a clone
c <- b$clone()
expect_identical(c$getx(), 2)
c$x <- 3
expect_identical(c$getx(), 3)
})
test_that("Cloning non-portable objects with public only", {
parenv <- new.env()
AC <- R6Class("AC",
portable = FALSE,
public = list(
x = 1,
getx = function() self$x
),
parent_env = parenv
)
# Behavioral tests
a <- AC$new()
b <- a$clone()
b$x <- 2
expect_identical(a$getx(), 1)
expect_identical(b$getx(), 2)
# Enclosing environment for methods
a_enclos_env <- environment(a$getx)
b_enclos_env <- environment(b$getx)
# Enclosing env is identical to public binding env
expect_identical(a_enclos_env, a)
expect_identical(b_enclos_env, b)
# self points back to the object (public binding env)
expect_identical(a$self, a)
expect_identical(b$self, b)
# Parent of enclosing env should be class's parent_env
expect_identical(parent.env(a_enclos_env), parenv)
expect_identical(parent.env(b_enclos_env), parenv)
# Contains correct objects
expect_identical(ls(a), c("clone", "getx", "self", "x"))
expect_identical(ls(b), c("clone", "getx", "self", "x"))
})
test_that("Cloning portable objects with public and private", {
parenv <- new.env()
AC <- R6Class("AC",
portable = TRUE,
public = list(
x = 1,
getx = function() self$x,
getprivate = function() private,
sety = function(value) private$y <- value
),
private = list(
y = 1,
gety = function() private$y
),
parent_env = parenv
)
# Behavioral tests
a <- AC$new()
b <- a$clone()
b$x <- 2
b$sety(2)
expect_identical(a$getx(), 1)
expect_identical(a$getprivate()$gety(), 1)
expect_identical(b$getx(), 2)
expect_identical(b$getprivate()$gety(), 2)
# Enclosing environment for methods
a_enclos_env <- environment(a$getx)
b_enclos_env <- environment(b$getx)
# Enclosing environment for private methods is same
expect_identical(a_enclos_env, environment(a$getprivate()$gety))
expect_identical(b_enclos_env, environment(b$getprivate()$gety))
# self points to the object (public binding env)
expect_identical(a_enclos_env$self, a)
expect_identical(b_enclos_env$self, b)
# Parent of enclosing env should be class's parent_env
expect_identical(parent.env(a_enclos_env), parenv)
expect_identical(parent.env(b_enclos_env), parenv)
# Parent of public binding env is emptyenv(), for portable classes
expect_identical(parent.env(a), emptyenv())
expect_identical(parent.env(b), emptyenv())
# Parent of private binding env is emptyenv(), for portable classes
expect_identical(parent.env(a$getprivate()), emptyenv())
expect_identical(parent.env(b$getprivate()), emptyenv())
# Enclosing env only contains self and private
expect_identical(ls(a_enclos_env), c("private", "self"))
expect_identical(ls(b_enclos_env), c("private", "self"))
# public binding env contains just the public members
expect_identical(ls(a), c("clone", "getprivate", "getx", "sety", "x"))
expect_identical(ls(b), c("clone", "getprivate", "getx", "sety", "x"))
# private binding env contains just the private members
expect_identical(ls(a$getprivate()), c("gety", "y"))
expect_identical(ls(b$getprivate()), c("gety", "y"))
})
test_that("Cloning non-portable objects with public and private", {
parenv <- new.env()
AC <- R6Class("AC",
portable = FALSE,
public = list(
x = 1,
getx = function() self$x,
getprivate = function() private,
sety = function(value) private$y <- value
),
private = list(
y = 1,
gety = function() private$y
),
parent_env = parenv
)
# Behavioral tests
a <- AC$new()
b <- a$clone()
b$x <- 2
b$sety(2)
expect_identical(a$getx(), 1)
expect_identical(a$getprivate()$gety(), 1)
expect_identical(b$getx(), 2)
expect_identical(b$getprivate()$gety(), 2)
# Enclosing environment for methods
a_enclos_env <- environment(a$getx)
b_enclos_env <- environment(b$getx)
# Enclosing env is identical to public binding env
expect_identical(a_enclos_env, a)
expect_identical(b_enclos_env, b)
# Enclosing environment for private methods is same
expect_identical(a_enclos_env, environment(a$getprivate()$gety))
expect_identical(b_enclos_env, environment(b$getprivate()$gety))
# self points to the object (public binding env)
expect_identical(a_enclos_env$self, a)
expect_identical(b_enclos_env$self, b)
# Parent of enclosing env should be private env
expect_identical(parent.env(a), a$getprivate())
expect_identical(parent.env(b), b$getprivate())
# Parent of private env should be class's parent_env
expect_identical(parent.env(a$getprivate()), parenv)
expect_identical(parent.env(b$getprivate()), parenv)
# Public binding env (AKA enclosing env) contains self, private, and members
expect_identical(ls(a),
c("clone", "getprivate", "getx", "private", "self", "sety", "x"))
expect_identical(ls(b),
c("clone", "getprivate", "getx", "private", "self", "sety", "x"))
# private binding env contains just the private members
expect_identical(ls(a$getprivate()), c("gety", "y"))
expect_identical(ls(b$getprivate()), c("gety", "y"))
})
test_that("Cloning subclasses with inherited private fields", {
# For issue #72
AC <- R6Class("AC",
public = list(
getx = function() private$x
),
private = list(
x = 1
)
)
BC <- R6Class("BC",
inherit = AC,
public = list(
getx = function() super$getx()
)
)
b1 <- BC$new()
b2 <- b1$clone()
expect_identical(b1$getx(), 1)
expect_identical(b2$getx(), 1)
})
test_that("Cloning active bindings", {
AC <- R6Class("AC",
public = list(
x = 1
),
active = list(
x2 = function(value) {
if (missing(value)) self$x * 2
else self$x <- value / 2
}
)
)
a <- AC$new()
b <- a$clone()
a$x <- 10
expect_identical(a$x2, 20)
a$x2 <- 22
expect_identical(a$x, 11)
expect_identical(b$x2, 2)
b$x <- 2
expect_identical(b$x2, 4)
b$x2 <- 10
expect_identical(b$x, 5)
})
test_that("Cloning active binding in superclass", {
AC <- R6Class("AC",
public = list(
x = 1
),
active = list(
x2 = function(value){
if (missing(value)) self$x * 2
else self$x <- value / 2
}
)
)
BC <- R6Class("BC",
inherit = AC,
active = list(
x2 = function(value){
if (missing(value)) super$x2 * 2
else super$x2 <- value / 2
}
)
)
a <- AC$new()
a$x <- 10
expect_identical(a$x2, 20)
a$x2 <- 22
expect_identical(a$x, 11)
b <- BC$new()
b$x <- 10
expect_identical(b$x2, 40)
b$x <- 11
expect_identical(b$x2, 44)
b1 <- b$clone()
expect_identical(b1$x2, 44)
b1$x <- 12
expect_identical(b1$x2, 48)
})
test_that("Cloning active binding in two levels of inheritance", {
# For issue #119
A <- R6Class("A",
public = list(
methodA = function() "A"
),
active = list(
x = function() "x"
)
)
B <- R6Class("B",
inherit = A,
public = list(
methodB = function() {
super$methodA()
}
)
)
C <- R6Class("C",
inherit = B,
public = list(
methodC = function() {
super$methodB()
}
)
)
C1 <- C$new()
C2 <- C1$clone()
expect_identical(C2$methodC(), "A")
expect_identical(
C1$.__enclos_env__$super$.__enclos_env__,
environment(C1$.__enclos_env__$super$methodB)
)
})
test_that("Active bindings are not touched during cloning", {
AC <- R6Class("AC",
public = list(
x = 1
),
active = list(
inc = function() {
self$x <- self$x + 1
self$x
}
)
)
a <- AC$new()
b <- a$clone()
expect_identical(a$x, 1)
expect_identical(b$x, 1)
})
test_that("Lock state", {
AC <- R6Class("AC",
public = list(
x = 1,
yval = function(y) {
if (missing(y)) private$y
else private$y <- y
}
),
private = list(w = 1),
lock_objects = TRUE
)
a <- AC$new()
b <- a$clone()
expect_error(a$z <- 1)
expect_error(b$z <- 1)
expect_identical(a$yval(), NULL)
expect_identical(b$yval(), NULL)
expect_error(a$yval(1))
expect_error(b$yval(1))
# With lock = FALSE
AC <- R6Class("AC",
public = list(
x = 1,
yval = function(y) {
if (missing(y)) private$y
else private$y <- y
}
),
private = list(w = 1),
lock_objects = FALSE
)
a <- AC$new()
b <- a$clone()
a$y <- 1
b$y <- 1
expect_identical(a$y, 1)
expect_identical(b$y, 1)
expect_identical(a$yval(), NULL)
expect_identical(b$yval(), NULL)
a$yval(1)
b$yval(1)
expect_identical(a$yval(), 1)
expect_identical(b$yval(), 1)
})
test_that("Cloning and inheritance of parent env", {
# ==========================
# Portable
# ==========================
A <- local({
y <- 1
R6Class("A",
public = list(
x = 1,
getx = function() self$x,
gety = function() y
)
)
})
# Check the environments of the original class
a <- A$new()
expect_identical(a$.__enclos_env__, environment(a$getx))
expect_identical(a, a$.__enclos_env__$self)
a2 <- a$clone()
expect_identical(a2$.__enclos_env__, environment(a2$getx))
expect_identical(a2, a2$.__enclos_env__$self)
expect_false(identical(a, a2))
B <- local({
y <- 2
R6Class("B",
inherit = A,
public = list(
getx_super = function() super$getx(),
gety_super = function() super$gety()
)
)
})
b <- B$new()
expect_false(exists("super", envir = environment(b$getx)))
expect_false(identical(b$.__enclos_env__, environment(b$getx)))
expect_true(exists("y", envir = parent.env(environment(b$getx))))
# If the method is inherited, the super (of the object, not the method) method
# should be the same as the inherited method
expect_identical(b$.__enclos_env__$super$getx, b$getx)
expect_identical(b, environment(b$getx)$self)
# Inherited method
expect_identical(b$getx(), 1)
# Method which calls super
expect_identical(b$getx_super(), 1)
expect_identical(b$gety(), 1)
expect_identical(b$gety_super(), 1)
b2 <- b$clone()
expect_false(exists("super", envir = environment(b2$getx)))
expect_false(identical(b2$.__enclos_env__, environment(b2$getx)))
expect_true(exists("y", envir = parent.env(environment(b2$getx))))
# If the method is inherited, the super (of the object, not the method) method
# should be the same as the inherited method
expect_identical(b2$.__enclos_env__$super$getx, b2$getx)
expect_identical(b2, environment(b2$getx)$self)
expect_identical(b2$getx(), 1)
expect_identical(b2$getx_super(), 1)
expect_identical(b$gety(), 1)
expect_identical(b$gety_super(), 1)
b2$x <- 3
expect_identical(b2$getx(), 3)
expect_identical(b2$getx_super(), 3)
C <- local({
y <- 3
R6Class("C",
inherit = B,
public = list(
getx_super = function() super$getx(),
gety_super = function() super$gety()
)
)
})
c <- C$new()
expect_false(exists("super", envir = environment(c$getx)))
expect_false(identical(c$.__enclos_env__, environment(b$getx)))
expect_true(exists("y", envir = parent.env(environment(c$getx))))
# If the method is inherited, the super (of the object, not the method) method
# should be the same as the inherited method
expect_identical(c$.__enclos_env__$super$getx, c$getx)
expect_identical(c, environment(c$getx)$self)
# Inherited method
expect_identical(c$getx(), 1)
# Method which calls super
expect_identical(c$getx_super(), 1)
expect_identical(c$gety(), 1)
expect_identical(c$gety_super(), 1)
c2 <- c$clone()
expect_false(exists("super", envir = environment(c2$getx)))
expect_false(identical(c2$.__enclos_env__, environment(c2$getx)))
expect_true(exists("y", envir = parent.env(environment(c2$getx))))
# If the method is inherited, the super (of the object, not the method) method
# should be the same as the inherited method
expect_identical(c2$.__enclos_env__$super$getx, c2$getx)
expect_identical(c2, environment(c2$getx)$self)
expect_identical(c2$getx(), 1)
expect_identical(c2$getx_super(), 1)
expect_identical(c$gety(), 1)
expect_identical(c$gety_super(), 1)
# ==========================
# Non-portable
# ==========================
A <- local({
y <- 1
R6Class("A",
portable = FALSE,
public = list(
x = 1,
getx = function() x,
gety = function() y
)
)
})
# Check the environments of the original class
a <- A$new()
expect_identical(a, environment(a$getx))
expect_identical(a, a$.__enclos_env__)
a2 <- a$clone()
expect_identical(a, environment(a$getx))
expect_identical(a, a$.__enclos_env__)
expect_false(identical(a, a2))
B <- local({
y <- 2
R6Class("B",
portable = FALSE,
inherit = A,
public = list(
getx_super = function() super$getx(),
gety_super = function() super$gety()
)
)
})
b <- B$new()
expect_identical(b, parent.env(environment(b$getx)))
expect_identical(b, b$.__enclos_env__)
# The parent of the enclosing env of a super method should be the object
# itself.
expect_identical(parent.env(environment(b$super$getx)), b)
# Inherited method
expect_identical(b$getx(), 1)
# Method which calls super
expect_identical(b$getx_super(), 1)
# Because portable=F, the inherited method gets the subclass's environment.
expect_identical(b$gety(), 2)
expect_identical(b$gety_super(), 2)
b2 <- b$clone()
expect_identical(b2, parent.env(environment(b2$getx)))
expect_identical(b2, b2$.__enclos_env__)
expect_identical(parent.env(environment(b2$super$getx)), b2)
expect_identical(b2$getx(), 1)
expect_identical(b2$getx_super(), 1)
expect_identical(b2$gety(), 2)
expect_identical(b2$gety_super(), 2)
# The original and the clone have the same parent env
expect_identical(parent.env(b), parent.env(b2))
b2$x <- 3
expect_identical(b2$getx(), 3)
expect_identical(b2$getx_super(), 3)
b3 <- b2$clone()
expect_identical(b3$getx(), 3)
expect_identical(b3$getx_super(), 3)
expect_identical(b3$gety(), 2)
expect_identical(b3$gety_super(), 2)
C <- local({
y <- 3
R6Class("C",
portable = FALSE,
inherit = B,
public = list(
getx_super = function() super$getx(),
gety_super = function() super$gety()
)
)
})
c <- C$new()
expect_identical(c, parent.env(environment(c$getx)))
expect_identical(c, c$.__enclos_env__)
# The parent of the enclosing env of a super method should be the object
# itself.
expect_identical(parent.env(environment(c$super$getx)), c)
# Inherited method
expect_identical(c$getx(), 1)
# Method which calls super
expect_identical(c$getx_super(), 1)
# Because portable=F, the inherited method gets the subclass's environment.
expect_identical(c$gety(), 3)
expect_identical(c$gety_super(), 3)
c2 <- c$clone()
expect_identical(c2, parent.env(environment(c2$getx)))
expect_identical(c2, c2$.__enclos_env__)
expect_identical(parent.env(environment(c2$super$getx)), c2)
expect_identical(c2$getx(), 1)
expect_identical(c2$getx_super(), 1)
expect_identical(c2$gety(), 3)
expect_identical(c2$gety_super(), 3)
# The original and the clone have the same parent env
expect_identical(parent.env(c), parent.env(c2))
})
test_that("Cloning inherited methods for portable classes", {
# This set of tests makes sure that inherited methods refer to the correct
# self, private, and super. They also test multiple levels of inheritance.
# Base class
C1 <- R6Class("C1",
public = list(
x = 1,
addx = function() self$x + 100,
p_addx = function() private$addx_()
),
private = list(
addx_ = function() self$x + 100
),
active = list(
a_addx = function(val) self$x + 100
)
)
# ==== Inherited methods ====
C2_inherit <- R6Class("C2_inherit",
inherit = C1,
public = list(
x = 2
)
)
a <- C2_inherit$new()
b <- a$clone()
expect_identical(a$addx(), 102)
expect_identical(a$p_addx(), 102)
expect_identical(a$a_addx, 102)
expect_identical(a$addx(), b$addx())
expect_identical(a$p_addx(), b$p_addx())
expect_identical(a$a_addx, b$a_addx)
b$x <- 3
expect_identical(b$addx(), 103)
expect_identical(b$p_addx(), 103)
expect_identical(b$a_addx, 103)
# Make sure a was unaffected
expect_identical(a$x, 2)
# ==== Overridden methods ====
C2_override <- R6Class("C2_override",
inherit = C1,
public = list(
x = 2,
addx = function() super$addx() + self$x + 1000
),
private = list(
addx_ = function() super$addx_() + self$x + 1000
),
active = list(
a_addx = function(val) super$a_addx + self$x + 1000
)
)
a <- C2_override$new()
b <- a$clone()
expect_identical(a$addx(), 1104)
expect_identical(a$p_addx(), 1104)
expect_identical(a$a_addx, 1104)
expect_identical(a$addx(), b$addx())
expect_identical(a$p_addx(), b$p_addx())
expect_identical(a$a_addx, b$a_addx)
b$x <- 3
expect_identical(b$addx(), 1106)
expect_identical(b$p_addx(), 1106)
expect_identical(b$a_addx, 1106)
# Make sure a was unaffected
expect_identical(a$x, 2)
# ===========================================================================
# Sub-sub-classes:
# Need to check sequences of:
# inherit-inherit, inherit-override, override-inherit, and override-override
# ==== Inherit-inherit methods ====
C3_inherit_inherit <- R6Class("C3_inherit_inherit",
inherit = C2_inherit,
public = list(
x = 3
)
)
a <- C3_inherit_inherit$new()
b <- a$clone()
expect_identical(a$addx(), 103)
expect_identical(a$p_addx(), 103)
expect_identical(a$a_addx, 103)
expect_identical(a$addx(), b$addx())
expect_identical(a$p_addx(), b$p_addx())
expect_identical(a$a_addx, b$a_addx)
b$x <- 4
expect_identical(b$addx(), 104)
expect_identical(b$p_addx(), 104)
expect_identical(b$a_addx, 104)
# Make sure a was unaffected
expect_identical(a$x, 3)
# ==== Inherit-override methods ====
C3_inherit_override <- R6Class("C3_inherit_override",
inherit = C2_inherit,
public = list(
x = 3,
addx = function() super$addx() + self$x + 10000
),
private = list(
addx_ = function() super$addx_() + self$x + 10000
),
active = list(
a_addx = function(val) super$a_addx + self$x + 10000
)
)
a <- C3_inherit_override$new()
b <- a$clone()
expect_identical(a$addx(), 10106)
expect_identical(a$p_addx(), 10106)
expect_identical(a$a_addx, 10106)
expect_identical(a$addx(), b$addx())
expect_identical(a$p_addx(), b$p_addx())
expect_identical(a$a_addx, b$a_addx)
b$x <- 4
expect_identical(b$addx(), 10108)
expect_identical(b$p_addx(), 10108)
expect_identical(b$a_addx, 10108)
# Make sure a was unaffected
expect_identical(a$x, 3)
# ==== Override-override methods ====
C3_override_override <- R6Class("C3_override_override",
inherit = C2_override,
public = list(
x = 3,
addx = function() super$addx() + self$x + 10000
),
private = list(
addx_ = function() super$addx_() + self$x + 10000
),
active = list(
a_addx = function(val) super$a_addx + self$x + 10000
)
)
a <- C3_override_override$new()
b <- a$clone()
expect_identical(a$addx(), 11109)
expect_identical(a$p_addx(), 11109)
expect_identical(a$a_addx, 11109)
expect_identical(a$addx(), b$addx())
expect_identical(a$p_addx(), b$p_addx())
expect_identical(a$a_addx, b$a_addx)
b$x <- 4
expect_identical(b$addx(), 11112)
expect_identical(b$p_addx(), 11112)
expect_identical(b$a_addx, 11112)
# Make sure a was unaffected
expect_identical(a$x, 3)
# ==== Override-inherit methods ====
C3_override_inherit <- R6Class("C3_override_inherit",
inherit = C2_override,
public = list(
x = 3
)
)
a <- C3_override_inherit$new()
b <- a$clone()
expect_identical(a$addx(), 1106)
expect_identical(a$p_addx(), 1106)
expect_identical(a$a_addx, 1106)
expect_identical(a$addx(), b$addx())
expect_identical(a$p_addx(), b$p_addx())
expect_identical(a$a_addx, b$a_addx)
b$x <- 4
expect_identical(b$addx(), 1108)
expect_identical(b$p_addx(), 1108)
expect_identical(b$a_addx, 1108)
# Make sure a was unaffected
expect_identical(a$x, 3)
})
test_that("Cloning inherited methods for non-portable classes", {
# This set of tests makes sure that inherited methods refer to the correct
# self, private, and super. They also test multiple levels of inheritance.
# Base class
C1 <- R6Class("C1",
portable = FALSE,
public = list(
x = 1,
addx = function() x + 100,
p_addx = function() addx_()
),
private = list(
addx_ = function() x + 100
),
active = list(
a_addx = function(val) x + 100
)
)
# ==== Inherited methods ====
C2_inherit <- R6Class("C2_inherit",
inherit = C1,
portable = FALSE,
public = list(
x = 2
)
)
a <- C2_inherit$new()
b <- a$clone()
expect_identical(a$addx(), 102)
expect_identical(a$p_addx(), 102)
expect_identical(a$a_addx, 102)
expect_identical(a$addx(), b$addx())
expect_identical(a$p_addx(), b$p_addx())
expect_identical(a$a_addx, b$a_addx)
b$x <- 3
expect_identical(b$addx(), 103)
expect_identical(b$p_addx(), 103)
expect_identical(b$a_addx, 103)
# Make sure a was unaffected
expect_identical(a$x, 2)
# ==== Overridden methods ====
C2_override <- R6Class("C2_override",
portable = FALSE,
inherit = C1,
public = list(
x = 2,
addx = function() super$addx() + x + 1000
),
private = list(
addx_ = function() super$addx_() + x + 1000
),
active = list(
a_addx = function(val) super$a_addx + x + 1000
)
)
a <- C2_override$new()
b <- a$clone()
expect_identical(a$addx(), 1104)
expect_identical(a$p_addx(), 1104)
expect_identical(a$a_addx, 1104)
expect_identical(a$addx(), b$addx())
expect_identical(a$p_addx(), b$p_addx())
expect_identical(a$a_addx, b$a_addx)
b$x <- 3
expect_identical(b$addx(), 1106)
expect_identical(b$p_addx(), 1106)
expect_identical(b$a_addx, 1106)
# Make sure a was unaffected
expect_identical(a$x, 2)
# ===========================================================================
# Sub-sub-classes:
# Need to check sequences of:
# inherit-inherit, inherit-override, override-inherit, and override-override
# ==== Inherit-inherit methods ====
C3_inherit_inherit <- R6Class("C3_inherit_inherit",
portable = FALSE,
inherit = C2_inherit,
public = list(
x = 3
)
)
a <- C3_inherit_inherit$new()
b <- a$clone()
expect_identical(a$addx(), 103)
expect_identical(a$p_addx(), 103)
expect_identical(a$a_addx, 103)
expect_identical(a$addx(), b$addx())
expect_identical(a$p_addx(), b$p_addx())
expect_identical(a$a_addx, b$a_addx)
b$x <- 4
expect_identical(b$addx(), 104)
expect_identical(b$p_addx(), 104)
expect_identical(b$a_addx, 104)
# Make sure a was unaffected
expect_identical(a$x, 3)
# ==== Inherit-override methods ====
C3_inherit_override <- R6Class("C3_inherit_override",
portable = FALSE,
inherit = C2_inherit,
public = list(
x = 3,
addx = function() super$addx() + x + 10000
),
private = list(
addx_ = function() super$addx_() + x + 10000
),
active = list(
a_addx = function(val) super$a_addx + x + 10000
)
)
a <- C3_inherit_override$new()
b <- a$clone()
expect_identical(a$addx(), 10106)
expect_identical(a$p_addx(), 10106)
expect_identical(a$a_addx, 10106)
expect_identical(a$addx(), b$addx())
expect_identical(a$p_addx(), b$p_addx())
expect_identical(a$a_addx, b$a_addx)
b$x <- 4
expect_identical(b$addx(), 10108)
expect_identical(b$p_addx(), 10108)
expect_identical(b$a_addx, 10108)
# Make sure a was unaffected
expect_identical(a$x, 3)
# ==== Override-override methods ====
C3_override_override <- R6Class("C3_override_override",
portable = FALSE,
inherit = C2_override,
public = list(
x = 3,
addx = function() super$addx() + x + 10000
),
private = list(
addx_ = function() super$addx_() + x + 10000
),
active = list(
a_addx = function(val) super$a_addx + x + 10000
)
)
a <- C3_override_override$new()
b <- a$clone()
expect_identical(a$addx(), 11109)
expect_identical(a$p_addx(), 11109)
expect_identical(a$a_addx, 11109)
expect_identical(a$addx(), b$addx())
expect_identical(a$p_addx(), b$p_addx())
expect_identical(a$a_addx, b$a_addx)
b$x <- 4
expect_identical(b$addx(), 11112)
expect_identical(b$p_addx(), 11112)
expect_identical(b$a_addx, 11112)
# Make sure a was unaffected
expect_identical(a$x, 3)
# ==== Override-inherit methods ====
C3_override_inherit <- R6Class("C3_override_inherit",
portable = FALSE,
inherit = C2_override,
public = list(
x = 3
)
)
a <- C3_override_inherit$new()
b <- a$clone()
expect_identical(a$addx(), 1106)
expect_identical(a$p_addx(), 1106)
expect_identical(a$a_addx, 1106)
expect_identical(a$addx(), b$addx())
expect_identical(a$p_addx(), b$p_addx())
expect_identical(a$a_addx, b$a_addx)
b$x <- 4
expect_identical(b$addx(), 1108)
expect_identical(b$p_addx(), 1108)
expect_identical(b$a_addx, 1108)
# Make sure a was unaffected
expect_identical(a$x, 3)
})
test_that("In deep_clone(), don't try to clone non-R6 objects", {
`$.test` <- function(x, value) {
stop("error")
}
AC <- R6Class("AC",
public = list(
x = NULL,
initialize = function() {
x <- new.env(parent = emptyenv())
class(x) <- "test"
self$x <- x
}
)
)
obj <- AC$new()
obj2 <- obj$clone(deep = TRUE)
expect_identical(obj$x, obj2$x)
})
test_that("Deep cloning", {
AC <- R6Class("AC", public = list(x = 1))
BC <- R6Class("BC",
public = list(
x = NULL,
y = function() private$y_,
initialize = function() {
self$x <- AC$new()
private$y_ <- AC$new()
}
),
private = list(
y_ = NULL
)
)
b <- BC$new()
b2 <- b$clone(deep = FALSE)
expect_identical(b$x, b2$x)
expect_identical(b$y(), b2$y())
b <- BC$new()
b2 <- b$clone(deep = TRUE)
expect_false(identical(b$x, b2$x))
expect_false(identical(b$y(), b2$y()))
# Make sure b2$x and b2$y are properly cloned R6 objects
expect_identical(class(b2$x), c("AC", "R6"))
expect_identical(class(b2$y()), c("AC", "R6"))
# Deep cloning with multiple levels
CC <- R6Class("CC",
public = list(
x = NULL,
initialize = function() {
self$x <- BC$new()
}
)
)
c <- CC$new()
c2 <- c$clone(deep = TRUE)
expect_false(identical(c$x, c2$x))
expect_false(identical(c$x$x, c2$x$x))
# Make sure c2$x and c2$x$x are properly cloned R6 objects
expect_identical(class(c2$x), c("BC", "R6"))
expect_identical(class(c2$x$x), c("AC", "R6"))
# Deep cloning with custom function
AC <- R6Class("AC", public = list(x = 1))
BC <- R6Class("BC",
public = list(
x = "AC",
y = "AC",
z = "AC",
initialize = function() {
self$x <- AC$new()
self$y <- AC$new()
self$z <- AC$new()
}
),
private = list(
deep_clone = function(name, val) {
if (name %in% c("x", "y"))
val$clone()
else
val
}
)
)
a <- BC$new()
b <- a$clone()
c <- a$clone(deep = TRUE)
a$x$x <- 2
a$y$x <- 3
a$z$x <- 4
# b is shallow clone
expect_identical(a$x$x, b$x$x)
expect_identical(a$y$x, b$y$x)
expect_identical(a$z$x, b$z$x)
# c has deep clones of x and y, but not z
expect_identical(c$x$x, 1)
expect_identical(c$y$x, 1)
expect_identical(a$z$x, c$z$x)
})
test_that("Deep cloning non-portable classes", {
# Make sure deep cloning doesn't lead to infinite loop because of `self`
AC <- R6Class("AC", portable = FALSE, public = list(x = 1))
a <- AC$new()
a$x <- 2
a2 <- a$clone(deep = TRUE)
expect_identical(a2$x, 2)
expect_identical(a2$self, a2)
})
test_that("Cloning with functions that are not methods", {
x <- 0
local_x1 <- local({
x <- 1
function() x
})
AC <- R6Class("AC",
public = list(
f = NULL,
method = function() 100
)
)
a <- AC$new()
a$f <- local_x1
expect_identical(a$f(), 1)
a2 <- a$clone()
expect_identical(a2$f(), 1)
# Clone of a clone
a3 <- a$clone()
expect_identical(a3$f(), 1)
# Make sure that in clones, methods are locked, and non-methods are not
# locked.
expect_no_error(a$f <- identity)
expect_no_error(a2$f <- identity)
expect_no_error(a3$f <- identity)
expect_error(a$method <- identity)
expect_error(a2$method <- identity)
expect_error(a3$method <- identity)
# ==== With inheritance ====
local_x2 <- local({
x <- 2
function() x
})
BC <- R6Class("BC",
inherit = AC,
public = list(
g = NULL
)
)
b <- BC$new()
b$f <- local_x1
b$g <- local_x2
expect_identical(b$f(), 1)
expect_identical(b$g(), 2)
b2 <- b$clone()
expect_identical(b2$f(), 1)
expect_identical(b2$g(), 2)
b3 <- b$clone()
expect_identical(b3$f(), 1)
expect_identical(b3$g(), 2)
})
test_that("Finalizers are run on cloned objects", {
sum <- 0
C1 <- R6Class("C1",
public = list(
x = 1,
finalize = function() sum <<- sum + self$x
)
)
a <- C1$new()
b <- a$clone()
b$x <- 10
rm(b)
gc()
expect_identical(sum, 10)
rm(a)
gc()
expect_identical(sum, 11)
# With inherited finalize method
sum <- 0
C2 <- R6Class("C2", inherit = C1)
a <- C2$new()
b <- a$clone()
b$x <- 10
rm(b)
gc()
expect_identical(sum, 10)
rm(a)
gc()
expect_identical(sum, 11)
# With overridden finalize method
sum <- 0
C3 <- R6Class("C3",
inherit = C1,
public = list(
finalize = function() sum <<- sum + 2*self$x
)
)
a <- C3$new()
b <- a$clone()
b$x <- 10
rm(b)
gc()
expect_identical(sum, 20)
rm(a)
gc()
expect_identical(sum, 22)
# With overridden finalize method which calls super$finalize
sum <- 0
C4 <- R6Class("C4",
inherit = C1,
public = list(
finalize = function() {
super$finalize()
sum <<- sum + 2*self$x
}
)
)
a <- C4$new()
b <- a$clone()
b$x <- 10
rm(b)
gc()
expect_identical(sum, 30)
rm(a)
gc()
expect_identical(sum, 33)
})
# Same tests as previous block, but with private finalizers
test_that("Finalizers (private) are run on cloned objects", {
sum <- 0
C1 <- R6Class("C1",
public = list(
x = 1
),
private = list(
finalize = function() sum <<- sum + self$x
)
)
a <- C1$new()
b <- a$clone()
b$x <- 10
rm(b)
gc()
expect_identical(sum, 10)
rm(a)
gc()
expect_identical(sum, 11)
# With inherited finalize method
sum <- 0
C2 <- R6Class("C2", inherit = C1)
a <- C2$new()
b <- a$clone()
b$x <- 10
rm(b)
gc()
expect_identical(sum, 10)
rm(a)
gc()
expect_identical(sum, 11)
# With overridden finalize method
sum <- 0
C3 <- R6Class("C3",
inherit = C1,
private = list(
finalize = function() sum <<- sum + 2*self$x
)
)
a <- C3$new()
b <- a$clone()
b$x <- 10
rm(b)
gc()
expect_identical(sum, 20)
rm(a)
gc()
expect_identical(sum, 22)
# With overridden finalize method which calls super$finalize
sum <- 0
C4 <- R6Class("C4",
inherit = C1,
private = list(
finalize = function() {
super$finalize()
sum <<- sum + 2*self$x
}
)
)
a <- C4$new()
b <- a$clone()
b$x <- 10
rm(b)
gc()
expect_identical(sum, 30)
rm(a)
gc()
expect_identical(sum, 33)
})
R6/tests/testthat/test-is.R 0000644 0001762 0000144 00000000473 14752476063 015300 0 ustar ligges users test_that("Checking R6 class objects are recognized correctly by `is.R6()`", {
Person <- R6Class("Person")
Bob <- Person$new()
expect_true(is.R6(Bob))
})
test_that("Checking R6 class generators are recognized correctly by `is.R6Class()`", {
Person <- R6Class("Person")
expect_true(is.R6Class(Person))
})
R6/tests/testthat/test-dollarnames.R 0000644 0001762 0000144 00000001422 14753731055 017155 0 ustar ligges users test_that(".DollarNames works as expected", {
AC <- R6Class("AC",
public = list(
x = 1,
.y = 1
),
private = list(
px = 1,
.py = 1
),
active = list(
ax = function(value) 1,
.ay = function(value) 1
)
)
a <- AC$new()
expected_names <- c("x", ".y", "ax", ".ay", "clone")
expect_setequal(.DollarNames(a, ""), expected_names)
expect_setequal(utils:::.DollarNames(a, ""), expected_names)
# Tests for direct calling of .DollarNames.R6 without S3 dispatch
# https://github.com/rstudio/rstudio/issue/15706
# https://github.com/rstudio/rstudio/pull/15707
expect_setequal(R6:::.DollarNames.R6(a, ""), expected_names)
DollarNamesR6 <- R6:::.DollarNames.R6
expect_setequal(DollarNamesR6(a, ""), expected_names)
})
R6/tests/testthat/test-nonportable-inheritance.R 0000644 0001762 0000144 00000015447 14752476063 021506 0 ustar ligges users test_that("Inheritance", {
AC <- R6Class("AC",
portable = FALSE,
public = list(
x = 0,
z = 0,
initialize = function(x) self$x <- x,
getx = function() x,
getx2 = function() x*2
),
private = list(
getz = function() z,
getz2 = function() z*2
),
active = list(
x2 = function(value) {
if (missing(value)) return(x * 2)
else x <<- value/2
},
x3 = function(value) {
if (missing(value)) return(x * 3)
else x <<- value/3
}
)
)
BC <- R6Class("BC",
portable = FALSE,
inherit = AC,
public = list(
y = 0,
z = 3,
initialize = function(x, y) {
super$initialize(x)
self$y <- y
},
getx = function() x + 10
),
private = list(
getz = function() z + 10
),
active = list(
x2 = function(value) {
if (missing(value)) return(x + 2)
else x <<- value-2
}
)
)
B <- BC$new(1, 2)
# Environment checks
expect_identical(B, environment(B$getx)) # Overridden public method
expect_identical(B, parent.env(environment(B$getx2))) # Inherited public method
expect_identical(B, environment(B$private$getz)) # Overridden private method
expect_identical(B, parent.env(environment(B$private$getz2))) # Inherited private method
# Behavioral tests
# Overriding literals
expect_identical(B$x, 1)
expect_identical(B$y, 2)
expect_identical(B$z, 3) # Subclass value overrides superclass value
# Methods
expect_identical(B$getx(), 11) # Overridden public method
expect_identical(B$getx2(), 2) # Inherited public method
expect_identical(B$private$getz(), 13) # Overriden private method
expect_identical(B$private$getz2(), 6) # Inherited private method
# Active bindings
expect_identical(B$x2, 3) # Overridden
expect_identical(B$x3, 3) # Inherited
# Classes
expect_identical(class(B), c("BC", "AC", "R6"))
})
test_that("Inheritance: superclass methods", {
AC <- R6Class("AC",
portable = FALSE,
public = list(
x = 0,
initialize = function() {
inc_x()
inc_self_x()
inc_y()
inc_self_y()
incz
},
inc_x = function() x <<- x + 1,
inc_self_x = function() self$x <- self$x + 10,
inc = function(val) val + 1,
pinc = function(val) priv_inc(val), # Call private inc method
z = 0
),
private = list(
y = 0,
inc_y = function() y <<- y + 1,
inc_self_y = function() private$y <- private$y + 10,
priv_inc = function(val) val + 1
),
active = list(
incz = function(value) {
z <<- z + 1
}
)
)
BC <- R6Class("BC",
portable = FALSE,
inherit = AC,
public = list(
inc_x = function() x <<- x + 2,
inc_self_x = function() self$x <- self$x + 20,
inc = function(val) super$inc(val) + 20
),
private = list(
inc_y = function() y <<- y + 2,
inc_self_y = function() private$y <- private$y + 20,
priv_inc = function(val) super$priv_inc(val) + 20
),
active = list(
incz = function(value) {
z <<- z + 2
}
)
)
B <- BC$new()
# Environment checks
expect_identical(parent.env(B$super), emptyenv())
# Enclosing env for functions in $super is a child of $self
expect_identical(parent.env(environment(B$super$inc_x)), B)
# Testing overrides
expect_identical(B$x, 22) # Public
expect_identical(B$private$y, 22) # Private
expect_identical(B$z, 2) # Active
# Calling superclass methods
expect_identical(B$inc(0), 21)
expect_identical(B$pinc(0), 21)
# Multi-level inheritance
CC <- R6Class("CC",
portable = FALSE,
inherit = BC,
public = list(
inc_x = function() x <<- x + 3,
inc_self_x = function() self$x <- self$x + 30,
inc = function(val) super$inc(val) + 300
),
private = list(
inc_y = function() y <<- y + 3,
inc_self_y = function() private$y <- private$y + 30,
priv_inc = function(val) super$priv_inc(val) + 300
),
active = list(
incz = function(value) {
z <<- z + 3
}
)
)
C <- CC$new()
# Testing overrides
expect_identical(C$x, 33) # Public
expect_identical(C$private$y, 33) # Private
expect_identical(C$z, 3) # Active
# Calling superclass methods (two levels)
expect_identical(C$inc(0), 321)
expect_identical(C$pinc(0), 321)
# Classes
expect_identical(class(C), c("CC", "BC", "AC", "R6"))
})
test_that("Inheritance hierarchy for super$ methods", {
AC <- R6Class("AC",
portable = FALSE,
public = list(n = function() 0 + 1)
)
expect_identical(AC$new()$n(), 1)
BC <- R6Class("BC",
portable = FALSE,
public = list(n = function() super$n() + 10),
inherit = AC
)
expect_identical(BC$new()$n(), 11)
CC <- R6Class("CC",
portable = FALSE,
inherit = BC
)
# This should equal 11 because it inherits BC's n(), which adds 1 to AC's n()
expect_identical(CC$new()$n(), 11)
# Skipping one level of inheritance ---------------------------------
AC <- R6Class("AC",
portable = FALSE,
public = list(n = function() 0 + 1)
)
expect_identical(AC$new()$n(), 1)
BC <- R6Class("BC",
portable = FALSE,
inherit = AC
)
expect_identical(BC$new()$n(), 1)
CC <- R6Class("CC",
portable = FALSE,
public = list(n = function() super$n() + 100),
inherit = BC
)
# This should equal 101 because BC inherits AC's n()
expect_identical(CC$new()$n(), 101)
DC <- R6Class("DC",
portable = FALSE,
inherit = CC
)
# This should equal 101 because DC inherits CC's n(), and BC inherits AC's n()
expect_identical(DC$new()$n(), 101)
# Skipping two level of inheritance ---------------------------------
AC <- R6Class("AC",
portable = FALSE,
public = list(n = function() 0 + 1)
)
expect_identical(AC$new()$n(), 1)
BC <- R6Class("BC", portable = FALSE, inherit = AC)
expect_identical(BC$new()$n(), 1)
CC <- R6Class("CC", portable = FALSE, inherit = BC)
expect_identical(CC$new()$n(), 1)
})
test_that("Private env is created when all private members are inherited", {
# Private contains fields only
AC <- R6Class("AC",
portable = FALSE,
public = list(
getx = function() x,
getx2 = function() private$x
),
private = list(x = 1)
)
BC <- R6Class("BC", portable = FALSE, inherit = AC)
expect_identical(BC$new()$getx(), 1)
expect_identical(BC$new()$getx2(), 1)
# Private contains functions only
AC <- R6Class("AC",
portable = FALSE,
public = list(
getx = function() x(),
getx2 = function() private$x()
),
private = list(x = function() 1)
)
BC <- R6Class("BC", portable = FALSE, inherit = AC)
expect_identical(BC$new()$getx(), 1)
expect_identical(BC$new()$getx2(), 1)
})
R6/tests/testthat/test-finalizer.R 0000644 0001762 0000144 00000017400 14752476063 016646 0 ustar ligges users test_that("Finalizers are called, portable", {
parenv <- new.env()
parenv$peekaboo <- FALSE
AC <- R6Class("AC",
private = list(finalize = function() peekaboo <<- TRUE),
portable = TRUE,
parent_env = parenv
)
a <- AC$new()
rm(a)
gc()
expect_true(parenv$peekaboo)
})
test_that("Finalizers are called, non-portable", {
parenv <- new.env()
parenv$peekaboo <- FALSE
AC <- R6Class("AC",
private = list(finalize = function() peekaboo <<- TRUE),
portable = FALSE,
parent_env = parenv
)
a <- AC$new()
rm(a)
gc()
expect_true(parenv$peekaboo)
})
test_that("Finalizers have the right environment, portable", {
parenv <- new.env()
parenv$pub <- parenv$priv <- FALSE
AC <- R6Class(
"AC",
public = list(
mypub = TRUE
),
private = list(
finalize = function() { pub <<- self$mypub; priv <<- private$mypriv },
mypriv = TRUE
),
portable = TRUE,
parent_env = parenv
)
a <- AC$new()
rm(a)
gc()
expect_true(parenv$pub)
expect_true(parenv$priv)
})
test_that("Finalizers have the right environment, non-portable #1", {
parenv <- new.env()
parenv$pub <- parenv$priv <- FALSE
AC <- R6Class(
"AC",
public = list(
mypub = TRUE
),
private = list(
finalize = function() { pub <<- self$mypub; priv <<- private$mypriv },
mypriv = TRUE
),
portable = FALSE,
parent_env = parenv
)
a <- AC$new()
rm(a)
gc()
expect_true(parenv$pub)
expect_true(parenv$priv)
})
test_that("Finalizers have the right environment, non-portable #2", {
parenv <- new.env()
parenv$pub <- parenv$priv <- FALSE
AC <- R6Class(
"AC",
public = list(
mypub = TRUE
),
private = list(
finalize = function() { pub <<- mypub; priv <<- mypriv },
mypriv = TRUE
),
portable = FALSE,
parent_env = parenv
)
a <- AC$new()
rm(a)
gc()
expect_true(parenv$pub)
expect_true(parenv$priv)
})
test_that("Finalizers are inherited, portable", {
AC <- R6Class(
"AC",
private = list(
finalize = function() print("An AC was just deleted")
)
)
BC <- R6Class(
"BC",
inherit = AC
)
B <- BC$new()
expect_output({ rm(B); gc() }, "An AC was just deleted")
})
test_that("Children can override finalizers, portable", {
AC <- R6Class(
"AC",
private = list(
finalize = function() cat("An AC was just deleted")
)
)
BC <- R6Class(
"BC",
inherit = AC,
private = list(
finalize = function() cat("A BC was just deleted")
)
)
B <- BC$new()
## The anchors make sure that there is no extra output here
expect_output({ rm(B); gc() }, "^A BC was just deleted$")
})
test_that("Children can call finalizers in the parent, portable", {
AC <- R6Class(
"AC",
private = list(
finalize = function() cat("An AC was just deleted\n")
)
)
BC <- R6Class(
"BC",
inherit = AC,
private = list(
finalize = function() {
super$finalize()
cat("A BC was just deleted\n")
}
)
)
B <- BC$new()
expect_output(
{ rm(B); gc() },
"An AC was just deleted.*A BC was just deleted"
)
})
test_that("Finalizers and two levels of inheritance, portable", {
AC <- R6Class(
"AC",
private = list(
finalize = function() cat("An AC was just deleted\n")
)
)
BC <- R6Class(
"BC",
inherit = AC,
private = list(
finalize = function() {
super$finalize()
cat("A BC was just deleted\n")
}
)
)
CC <- R6Class(
"CC",
inherit = BC,
private = list(
finalize = function() {
super$finalize()
cat("A CC was just deleted\n")
}
)
)
C <- CC$new()
expect_output(
{ rm(C); gc() },
"An AC was just deleted.*A BC was just deleted.*A CC was just deleted"
)
})
test_that("Finalizers are inherited, non-portable", {
AC <- R6Class(
"AC",
private = list(
finalize = function() print("An AC was just deleted")
),
portable = FALSE
)
BC <- R6Class(
"BC",
inherit = AC,
portable = FALSE
)
B <- BC$new()
expect_output({ rm(B); gc() }, "An AC was just deleted")
})
test_that("Children can override finalizers, non-portable", {
AC <- R6Class(
"AC",
private = list(
finalize = function() cat("An AC was just deleted")
),
portable = FALSE
)
BC <- R6Class(
"BC",
inherit = AC,
private = list(
finalize = function() cat("A BC was just deleted")
),
portable = FALSE
)
B <- BC$new()
## The anchors make sure that there is no extra output here
expect_output({ rm(B); gc() }, "^A BC was just deleted$")
})
test_that("Children can call finalizers in the parent, non-portable", {
AC <- R6Class(
"AC",
private = list(
finalize = function() cat("An AC was just deleted\n")
),
portable = FALSE
)
BC <- R6Class(
"BC",
inherit = AC,
private = list(
finalize = function() {
super$finalize()
cat("A BC was just deleted\n")
}
),
portable = FALSE
)
B <- BC$new()
expect_output(
{ rm(B); gc() },
"An AC was just deleted.*A BC was just deleted"
)
})
test_that("Finalizers and two levels of inheritance, portable", {
AC <- R6Class(
"AC",
private = list(
finalize = function() cat("An AC was just deleted\n")
)
)
BC <- R6Class(
"BC",
inherit = AC,
private = list(
finalize = function() {
super$finalize()
cat("A BC was just deleted\n")
}
)
)
CC <- R6Class(
"CC",
inherit = BC,
private = list(
finalize = function() {
super$finalize()
cat("A CC was just deleted\n")
}
)
)
C <- CC$new()
expect_output(
{ rm(C); gc() },
"An AC was just deleted.*A BC was just deleted.*A CC was just deleted"
)
})
test_that("Finalizers and two levels of inheritance, non-portable", {
AC <- R6Class(
"AC",
private = list(
finalize = function() cat("An AC was just deleted\n")
),
portable = FALSE
)
BC <- R6Class(
"BC",
inherit = AC,
private = list(
finalize = function() {
super$finalize()
cat("A BC was just deleted\n")
}
),
portable = FALSE
)
CC <- R6Class(
"CC",
inherit = BC,
private = list(
finalize = function() {
super$finalize()
cat("A CC was just deleted\n")
}
),
portable = FALSE
)
C <- CC$new()
expect_output(
{ rm(C); gc() },
"An AC was just deleted.*A BC was just deleted.*A CC was just deleted"
)
})
# Issue #121
test_that("Finalizer method does not prevent GC of objects passed to initialize", {
a_gc <- 0
A <- R6Class(
"A",
public = list(
initialize = function(x) {
force(x) # Need to eval x
}
),
private = list(
finalize = function(e) {
a_gc <<- a_gc + 1
}
)
)
x_gc <- 0
x <- new.env(parent = emptyenv())
reg.finalizer(x, function(e) { x_gc <<- x_gc + 1 })
# Pass x to A's initialize method
a <- A$new(x)
rm(x)
gc()
expect_identical(x_gc, 1) # This is the key test: x should be GC'd
rm(a)
gc()
expect_identical(a_gc, 1)
# Same test, but with clone
a_gc <- 0
x_gc <- 0
x <- new.env(parent = emptyenv())
reg.finalizer(x, function(e) { x_gc <<- x_gc + 1 })
# Pass x to A's initialize method
a <- A$new(x)
b <- a$clone()
rm(x)
gc()
expect_identical(x_gc, 1) # This is the key test: x should be GC'd
rm(a)
gc()
expect_identical(a_gc, 1)
rm(b)
gc()
expect_identical(a_gc, 2)
expect_identical(x_gc, 1) # Make sure x's finalizer hasn't somehow run again
})
test_that("Public finalizers emit message", {
expect_message(
R6Class("C1",
public = list(
x = 1,
finalize = function() NULL
)
)
)
})
R6/tests/testthat.R 0000644 0001762 0000144 00000000060 14752476063 013700 0 ustar ligges users library(testthat)
library(R6)
test_check("R6")
R6/MD5 0000644 0001762 0000144 00000004122 14753762272 011067 0 ustar ligges users 398b9b248553e6c74fbe2b49458e3189 *DESCRIPTION
d6683a2afab33f1588738ac1ba8151d4 *LICENSE
23693bb8b34da00f747c803b39b982a3 *NAMESPACE
e82876657c660facb4181094f83e9830 *NEWS.md
df6cc46bc7fae1a55b713f3d5065b35a *R/R6-package.R
890797fed39cbc35799c315d9c322108 *R/aaa.R
8fc2b68dd2ba714c478255c42d60fdb5 *R/aslist.R
1cfa89e773bec51a44b770bb952ad760 *R/clone.R
969da6f631df9a1f7fbdf9531f60b4dc *R/env_utils.R
bdc3eed04493e6eda7707b085e127963 *R/generator_funs.R
da8d32330b60debc59dc9ce8a31e877c *R/is.R
8053880811151634afa62c571ee8d2eb *R/new.R
31f32ed63aacaf439848ef43dde09add *R/print.R
8c10252c8a9670ad42d99f95655be1ef *R/r6_class.R
b88a321a00815f8fbf23a3eac1790f5d *R/utils.R
1bd38c820258c938102c17f018cc269f *README.md
936b400c8bfa8ef20e78fa7b884d50d1 *man/R6-package.Rd
c6fde3343452a43963ead2a7c730e370 *man/R6Class.Rd
1ab85a3b47a7e9757b9e11fe9ab73441 *man/as.list.R6.Rd
ea0913a482ce1aa926631dd7bb46e330 *man/figures/logo.png
5f3ac92823b5ad4db8d362c634805c54 *man/figures/logo.svg
ba0b7a8329fd8be2251946b54e1119f5 *man/is.R6.Rd
792c2b5c02379e27e3eccbee832b2b28 *tests/manual/README
f076d70d4247e7a1b9091c2d721589b0 *tests/manual/encapsulation.R
d0c61e8ebb47f4bdf74bf4b02714109a *tests/manual/test-inheritance.R
08d4cdb1a57dc1e4307c6f4c8d83e65e *tests/testthat.R
45a99007ec8c0255886a2100904c2cae *tests/testthat/helper.R
6235741d7a56921f76b9a728bffe8cdf *tests/testthat/test-aslist.R
686f9b2b8c81aaba2742959cef2ca839 *tests/testthat/test-clone.R
689c5d4076b051c83022d07587df2fe7 *tests/testthat/test-cloning-inheritance.R
e9f132f2b1ec3830e2c67b5c4223e7db *tests/testthat/test-dollarnames.R
c1350f7af260b0bc173df4aedc4da9fb *tests/testthat/test-finalizer.R
ba27c46bf9552c83e49fb91f5da0bbcf *tests/testthat/test-is.R
37a118203b530ffd745aa3d38d3edea3 *tests/testthat/test-nonportable-inheritance.R
addac325d883add5bcfb332309c59572 *tests/testthat/test-nonportable.R
2f8093794acdfea12e410eea07f97518 *tests/testthat/test-portable-inheritance.R
c84bafe340571a01103e4c41059fa144 *tests/testthat/test-portable.R
0fcc179511642743dfa168a8e519d0cf *tests/testthat/test-s3-methods.R
e47c21529dc16c88e99b29f331badc9d *tests/testthat/test-set.R
R6/R/ 0000755 0001762 0000144 00000000000 14753731055 010754 5 ustar ligges users R6/R/print.R 0000644 0001762 0000144 00000010354 14752476063 012242 0 ustar ligges users #' @export
format.R6 <- function(x, ...) {
if (is.function(.subset2(x, "format"))) {
.subset2(x, "format")(...)
} else {
ret <- paste0("<", class(x)[1], ">")
# If there's another class besides first class and R6
classes <- setdiff(class(x), "R6")
if (length(classes) >= 2) {
ret <- c(ret, paste0(" Inherits from: <", classes[2], ">"))
}
ret <- c(ret,
" Public:",
indent(object_summaries(x, exclude = c(".__active__", ".__enclos_env__")), 4)
)
private <- .subset2(.subset2(x, ".__enclos_env__"), "private")
if (!is.null(private)) {
ret <- c(ret,
" Private:",
indent(object_summaries(private), 4)
)
}
paste(ret, collapse = "\n")
}
}
#' @export
print.R6 <- function(x, ...) {
if (is.function(.subset2(x, "print"))) {
.subset2(x, "print")(...)
} else {
cat(format(x, ...), sep = "\n")
}
invisible(x)
}
#' @export
format.R6ClassGenerator <- function(x, ...) {
classname <- x$classname
if (is.null(classname)) classname <- "unnamed"
ret <- paste0("<", classname, "> object generator")
if (!is.null(x$inherit)) {
ret <- c(ret, paste0(" Inherits from: <", deparse(x$inherit), ">"))
}
ret <- c(ret,
" Public:",
indent(object_summaries(x$public_fields), 4),
indent(object_summaries(x$public_methods), 4)
)
if (!is.null(x$active)) {
ret <- c(ret,
" Active bindings:",
indent(object_summaries(x$active), 4)
)
}
if (!(is.null(x$private_fields) && is.null(x$private_methods))) {
ret <- c(ret,
" Private:",
indent(object_summaries(x$private_fields), 4),
indent(object_summaries(x$private_methods), 4)
)
}
ret <- c(ret, paste(" Parent env:", format(x$parent_env)))
# R6 generators created by versions <2.1 could be used with this version of
# print. They had x$lock instead of x$lock_objects, and they didn't have
# x$lock_class at all. Make sure we don't error in that case. Eventually we'll
# be able to remove this check.
if (!is.null(x$lock) && is.logical(x$lock))
ret <- c(ret, paste(" Locked objects:", x$lock))
if (!is.null(x$lock_objects))
ret <- c(ret, paste(" Locked objects:", x$lock_objects))
if (!is.null(x$lock_class))
ret <- c(ret, paste(" Locked class:", x$lock_class))
ret <- c(ret, paste(" Portable:", x$portable))
paste(ret, collapse = "\n")
}
#' @export
print.R6ClassGenerator <- function(x, ...) {
cat(format(x, ...), sep = "\n")
}
# Return a summary string of the items of a list or environment
# x must be a list or environment
object_summaries <- function(x, exclude = NULL) {
if (length(x) == 0)
return(NULL)
if (is.list(x))
obj_names <- names(x)
else if (is.environment(x))
obj_names <- ls(x, all.names = TRUE)
obj_names <- setdiff(obj_names, exclude)
values <- vapply(obj_names, function(name) {
if (is.environment(x) && bindingIsActive(name, x)) {
"active binding"
} else {
obj <- .subset2(x, name)
if (is.function(obj)) deparse(args(obj))[[1L]]
# Plain environments (not envs with classes, like R6 or RefClass objects)
else if (is.environment(obj) && identical(class(obj), "environment")) "environment"
else if (is.null(obj)) "NULL"
else if (is.atomic(obj)) {
# If obj has many elements, paste() can be very slow, so we'll just
# use just a subset of it. https://github.com/r-lib/R6/issues/159
txt <- as.character(utils::head(obj, 60))
txt <- paste(txt, collapse = " ")
trim(txt)
}
else paste(class(obj), collapse = ", ")
}
}, FUN.VALUE = character(1))
paste0(obj_names, ": ", values, sep = "")
}
# Given a string, indent every line by some number of spaces.
# The exception is to not add spaces after a trailing \n.
indent <- function(str, indent = 0) {
gsub("(^|\\n)(?!$)",
paste0("\\1", paste(rep(" ", indent), collapse = "")),
str,
perl = TRUE
)
}
# Trim a string to n characters; if it's longer than n, add " ..." to the end
trim <- function(str, n = 60) {
if (nchar(str) > n) paste(substr(str, 1, n-4), "...")
else str
}
#' @export
plot.R6 <- function(x, ...) {
if (is.function(x$plot)) {
x$plot(...)
} else {
stop(paste0("No plot method defined for R6 class ", class(x)[1]))
}
}
R6/R/aaa.R 0000644 0001762 0000144 00000002366 14752476063 011634 0 ustar ligges users # This is the enclosing environment for all of the functions involved in
# instantiating objects. It is also the binding environment for all these
# functions, except for R6Class(). This is because a generator object can be
# saved (in a built package, for example) and then restored in a different R
# session which has a different version of the R6 package. With the capsule
# environment, the generator object doesn't need to use any functions or objects
# from the potentially different R6 namespace, and because the saved/restored
# object also saves and restores the capsule environment (but not the R6
# namespace).
capsule <- new.env(hash = FALSE)
attr(capsule, "name") <- "R6_capsule"
# This function takes an expression and evaluates it in the capsule environment.
encapsulate <- function(expr) {
expr <- substitute(expr)
eval(expr, capsule)
}
# This list contains functions that are copied to the generator environment and
# are assigned as the generator env as their enclosing environment.
# This is simpler than encapsulate, because these functions don't need to be
# enclosed in a special environment now; when a class is created, they will be
# copied into the generator environment and assigned it as their enclosing env.
generator_funs <- list()
R6/R/generator_funs.R 0000644 0001762 0000144 00000006073 14752476063 014132 0 ustar ligges users # This function returns the superclass object
generator_funs$get_inherit <- function() {
# The NULL arg speeds up eval a tiny bit
eval(inherit, parent_env, NULL)
}
# This is the $has_private function for a R6ClassGenerator. This copy of it
# won't run properly; it needs to be copied, and its parent environment set to
# the generator object environment.
# Returns TRUE if this class or one of its ancestor superclasses has private
# members; FALSE otherwise.
generator_funs$has_private <- function() {
inherit <- get_inherit()
if (!is.null(private_fields) || !is.null(private_methods))
TRUE
else if (is.null(inherit))
FALSE
else
inherit$has_private()
}
# This is the $set function for a R6ClassGenerator. This copy of it won't run
# properly; it needs to be copied, and its parent environment set to the
# generator object environment.
generator_funs$set <- function(which = NULL, name = NULL, value, overwrite = FALSE) {
if (lock_class)
stop("Can't modify a locked R6 class.")
if (is.null(which) || !(which %in% c("public", "private", "active")))
stop("`which` must be 'public', 'private', or 'active'.")
if (is.null(name) || !is.character(name))
stop("`name` must be a string.")
if (missing(value))
stop("`value` must be provided.")
# Find which group this object should go in.
if (which == "public") {
group <- if (is.function(value)) "public_methods" else "public_fields"
} else if (which == "private") {
group <- if (is.function(value)) "private_methods" else "private_fields"
} else if (which == "active") {
if (is.function(value))
group <- "active"
else
stop("Can't add non-function to active")
}
# Check that it's not already present
all_groups <- c("public_methods", "public_fields", "private_methods",
"private_fields", "active")
# If we're allowed to overwrite, don't check the group that this object
# would go in.
if (overwrite)
all_groups <- setdiff(all_groups, group)
all_names <- unlist(lapply(all_groups, function(g) names(get(g))))
if (name %in% all_names) {
stop("Can't add ", name, " because it already present in ", classname,
" generator.")
}
# Assign in correct group. Create group if it doesn't exist.
if (is.null(self[[group]]))
self[[group]] <- list()
if (is.null(value)) {
# If it's NULL, the item should get a NULL value. The `[[<-` assignment
# would instead delete the item; this method gives it a NULL value.
self[[group]][name] <- list(NULL)
} else {
self[[group]][[name]] <- value
}
invisible()
}
# Enable debugging for one or more methods. This will apply to all objects
# instantiated after this is called.
generator_funs$debug <- function(name) {
debug_names <<- union(debug_names, name)
}
# Disable debugging for one or more methods.
generator_funs$undebug <- function(name) {
debug_names <<- setdiff(debug_names, name)
}
generator_funs$lock <- function() {
lock_class <<- TRUE
}
generator_funs$unlock <- function() {
lock_class <<- FALSE
}
generator_funs$is_locked <- function() {
lock_class
}
R6/R/is.R 0000644 0001762 0000144 00000001326 14752476063 011520 0 ustar ligges users #' Is an object an R6 Class Generator or Object?
#'
#' Checks for R6 class generators and R6 objects.
#' @param x An object.
#' @return A logical value.
#' \itemize{
#' \item{\code{is.R6Class} returns \code{TRUE} when the input is an R6 class
#' generator and \code{FALSE} otherwise.}
#' \item{\code{is.R6} returns \code{TRUE} when the input is an R6 object and
#' \code{FALSE} otherwise.}
#' }
#' @examples
#' class_generator <- R6Class()
#' object <- class_generator$new()
#'
#' is.R6Class(class_generator)
#' is.R6(class_generator)
#'
#' is.R6Class(object)
#' is.R6(object)
#' @export
is.R6 <- function(x) {
inherits(x, "R6")
}
#' @rdname is.R6
#' @export
is.R6Class <- function(x) {
inherits(x, "R6ClassGenerator")
}
R6/R/aslist.R 0000644 0001762 0000144 00000000476 14752476063 012411 0 ustar ligges users #' Create a list from an R6 object
#'
#' This returns a list of public members from the object. It simply calls
#' \code{as.list.environment}.
#'
#' @param x An R6 object.
#' @param ... Other arguments, which will be ignored.
#'
#' @export
as.list.R6 <- function(x, ...) {
as.list.environment(x, all.names = TRUE)
}
R6/R/R6-package.R 0000644 0001762 0000144 00000000135 14752476063 012762 0 ustar ligges users #' @keywords internal
"_PACKAGE"
## usethis namespace: start
## usethis namespace: end
NULL
R6/R/utils.R 0000644 0001762 0000144 00000002331 14752476063 012242 0 ustar ligges users encapsulate({
# Given two named vectors, join them together, and keep only the last element
# with a given name in the resulting vector. If b has any elements with the
# same name as elements in a, the element in a is dropped. Also, if there are
# any duplicated names in a or b, only the last one with that name is kept.
merge_vectors <- function(a, b) {
if ((!is.null(a) && length(a) > 1 && is.null(names(a))) ||
(!is.null(b) && length(b) > 1 && is.null(names(b)))) {
stop("merge_vectors: vectors must be either NULL or named vectors")
}
x <- c(a, b)
drop_idx <- duplicated(names(x), fromLast = TRUE)
x[!drop_idx]
}
# Check that all elements of a list are named.
# NULL and empty lists return TRUE.
all_named <- function(x) {
if (length(names(x)) != length(x) || any(names(x) == "")) {
return(FALSE)
}
TRUE
}
# Return all the functions in a list.
get_functions <- function(x) {
funcs <- vapply(x, is.function, logical(1))
if (all(!funcs)) return(NULL)
x[funcs]
}
# Return all the non-functions in a list.
get_nonfunctions <- function(x) {
funcs <- vapply(x, is.function, logical(1))
if (all(funcs)) return(NULL)
x[!funcs]
}
})
R6/R/new.R 0000644 0001762 0000144 00000025635 14752476063 011707 0 ustar ligges users # This is the $new function for a R6ClassGenerator. This copy of it won't run
# properly; it needs to be copied, and its parent environment set to the
# generator object environment.
generator_funs$new <- function(...) {
# Get superclass object -------------------------------------------
inherit <- get_inherit()
# Some checks on superclass ---------------------------------------
if (!is.null(inherit)) {
if (!inherits(inherit, "R6ClassGenerator"))
stop("`inherit` must be a R6ClassGenerator.")
if (!identical(portable, inherit$portable))
stop("Sub and superclass must both be portable or non-portable.")
# Merge fields over superclass fields, recursively --------------
recursive_merge <- function(obj, which) {
if (is.null(obj)) return(NULL)
merge_vectors(recursive_merge(obj$get_inherit(), which), obj[[which]])
}
public_fields <- merge_vectors(recursive_merge(inherit, "public_fields"),
public_fields)
private_fields <- merge_vectors(recursive_merge(inherit, "private_fields"),
private_fields)
}
if (class) {
classes <- c(classname, get_superclassnames(inherit), "R6")
} else {
classes <- NULL
}
# Precompute some things ------------------------------------------
has_priv <- has_private()
# Create binding and enclosing environments -----------------------
if (portable) {
# When portable==TRUE, the public binding environment is separate from the
# enclosing environment.
# Binding environment for private objects (where private objects are found)
if (has_priv)
private_bind_env <- new.env(parent = emptyenv(), hash = FALSE)
else
private_bind_env <- NULL
# Binding environment for public objects (where public objects are found)
public_bind_env <- new.env(parent = emptyenv(), hash = FALSE)
# The enclosing environment for methods
enclos_env <- new.env(parent = parent_env, hash = FALSE)
} else {
# When portable==FALSE, the public binding environment is the same as the
# enclosing environment.
# If present, the private binding env is the parent of the public binding
# env.
if (has_priv) {
private_bind_env <- new.env(parent = parent_env, hash = FALSE)
public_bind_env <- new.env(parent = private_bind_env, hash = FALSE)
} else {
private_bind_env <- NULL
public_bind_env <- new.env(parent = parent_env, hash = FALSE)
}
enclos_env <- public_bind_env
}
# Add self and private pointer ------------------------------------
enclos_env$self <- public_bind_env
if (has_priv)
enclos_env$private <- private_bind_env
# Fix environment for methods -------------------------------------
public_methods <- assign_func_envs(public_methods, enclos_env)
if (has_priv)
private_methods <- assign_func_envs(private_methods, enclos_env)
if (!is.null(active))
active <- assign_func_envs(active, enclos_env)
# Enable debugging ------------------------------------------------
if (length(debug_names) > 0) {
lapply(public_methods[names(public_methods) %in% debug_names], base::debug)
lapply(private_methods[names(private_methods) %in% debug_names], base::debug)
lapply(active[names(active) %in% debug_names], base::debug)
}
# Set up superclass objects ---------------------------------------
if (!is.null(inherit)) {
if (portable) {
# Set up the superclass objects
super_struct <- create_super_env(inherit, public_bind_env,
private_bind_env, portable = TRUE)
} else {
# Set up the superclass objects
super_struct <- create_super_env(inherit, public_bind_env, portable = FALSE)
}
enclos_env$super <- super_struct$bind_env
# Merge this level's methods over the superclass methods
public_methods <- merge_vectors(super_struct$public_methods, public_methods)
private_methods <- merge_vectors(super_struct$private_methods, private_methods)
active <- merge_vectors(super_struct$active, active)
# If `cloneable` property differs between sub and superclass
# - super will override sub if super doesn't allow cloning
# - sub will override super if super allows cloning
if (!identical(cloneable, inherit$cloneable)) {
public_methods[["clone"]] <- NULL
if (!inherit$cloneable) {
message(
"Superclass ", inherit$classname, " has cloneable=FALSE, but subclass ", classname, " has cloneable=TRUE. ",
"A subclass cannot be cloneable when its superclass is not cloneable, so cloning will be disabled for ", classname, "."
)
}
}
}
# Copy objects to public bind environment -------------------------
list2env2(public_methods, envir = public_bind_env)
list2env2(public_fields, envir = public_bind_env)
# Copy objects to private bind environment ------------------------
if (has_priv) {
list2env2(private_methods, envir = private_bind_env)
list2env2(private_fields, envir = private_bind_env)
}
# Set up active bindings ------------------------------------------
if (!is.null(active)) {
for (name in names(active)) {
makeActiveBinding(name, active[[name]], public_bind_env)
}
# If there are active bindings, then we need to store a copy of the active
# bindings in case the object is cloned. This is because as of R 4.0,
# there's no way to get the function associated with an active binding;
# you can only get the return value.
enclos_env$`.__active__` <- active
}
# Add refs to other environments in the object --------------------
public_bind_env$`.__enclos_env__` <- enclos_env
# Lock ------------------------------------------------------------
if (lock_objects) {
if (has_priv) lockEnvironment(private_bind_env)
lockEnvironment(public_bind_env)
}
# Always lock methods
if (has_priv) {
for (name in names(private_methods))
lockBinding(name, private_bind_env)
}
for (name in names(public_methods))
lockBinding(name, public_bind_env)
class(public_bind_env) <- classes
# Initialize ------------------------------------------------------
initialize <- .subset2(public_bind_env, "initialize")
if (is.function(initialize)) {
initialize(...)
} else if (length(list(...)) != 0 ) {
stop("Called new() with arguments, but there is no initialize method.")
}
# Finalizer -------------------------------------------------------
if (is.function(.subset2(public_bind_env, "finalize"))) {
# This wraps the user's `finalize` method. The user's finalize method
# typically does not have an `e` argument, so the wrapper needs to consume
# the `e` argument.
finalizer_wrapper <- function(e) {
.subset2(e, "finalize")()
}
# Reassign the wrapper's environment so that it does not capture the current
# environment and prevent objects from getting GC'd.
environment(finalizer_wrapper) <- baseenv()
reg.finalizer(
public_bind_env,
finalizer_wrapper,
onexit = TRUE
)
}
if (has_priv) {
if (is.function(.subset2(private_bind_env, "finalize"))) {
finalizer_wrapper <- function(e) {
.subset2(e, ".__enclos_env__")$private$finalize()
}
environment(finalizer_wrapper) <- baseenv()
reg.finalizer(
public_bind_env,
finalizer_wrapper,
onexit = TRUE
)
}
}
public_bind_env
}
encapsulate({
# Create and populate the self$super environment, for non-portable case.
# In this function, we "climb to the top" of the superclass hierarchy by
# recursing early on in the function, and then fill the methods downward by
# doing the work for each level and passing the needed information down.
create_super_env <- function(inherit, public_bind_env, private_bind_env = NULL,
portable = TRUE) {
public_methods <- inherit$public_methods
private_methods <- inherit$private_methods
active <- inherit$active
# Set up super enclosing and binding environments -------------------
# The environment in which functions run is a child of the public bind env
# (AKA self).
# For portable classes, this is a child of the superclass's parent env.
# For non-portable classes, this is a child of self; however, self has no
# bindings that point to it. The only reason this environment is needed is so
# that if a function super$foo in turn calls super$bar, it will be able to
# find bar from the next superclass up.
if (portable)
enclos_parent <- inherit$parent_env
else
enclos_parent <- public_bind_env
super_enclos_env <- new.env(parent = enclos_parent, hash = FALSE)
# The binding environment is a new environment. Its parent doesn't matter
# because it's not the enclosing environment for any functions.
super_bind_env <- new.env(parent = emptyenv(), hash = FALSE)
# Need to store the enclosing environment for cloning.
super_bind_env$.__enclos_env__ <- super_enclos_env
# Add self/private pointers -----------------------------------------
if (portable) {
super_enclos_env$self <- public_bind_env
if (!is.null(private_bind_env))
super_enclos_env$private <- private_bind_env
}
# Set up method environments ----------------------------------------
# All the methods can be found in self$super (the binding env).
# Their enclosing env is a different environment.
public_methods <- assign_func_envs(public_methods, super_enclos_env)
private_methods <- assign_func_envs(private_methods, super_enclos_env)
active <- assign_func_envs(active, super_enclos_env)
# Recurse if there are more superclasses ----------------------------
inherit_inherit <- inherit$get_inherit()
if (!is.null(inherit_inherit)) {
super_struct <- create_super_env(inherit_inherit, public_bind_env,
private_bind_env, portable)
super_enclos_env$super <- super_struct$bind_env
# Merge this level's methods over the superclass methods
public_methods <- merge_vectors(super_struct$public_methods, public_methods)
private_methods <- merge_vectors(super_struct$private_methods, private_methods)
active <- merge_vectors(super_struct$active, active)
}
# Copy the methods into the binding environment ---------------------
list2env2(public_methods, envir = super_bind_env)
list2env2(private_methods, envir = super_bind_env)
if (!is.null(active)) {
for (name in names(active)) {
makeActiveBinding(name, active[[name]], super_bind_env)
}
# If there are active bindings, then we need to store a copy of the
# active bindings in case the object is cloned.
super_enclos_env$`.__active__` <- active
}
# Return an object with all the information needed to merge down
list(
bind_env = super_bind_env,
public_methods = public_methods,
private_methods = private_methods,
active = active
)
}
})
R6/R/env_utils.R 0000644 0001762 0000144 00000002501 14752476063 013111 0 ustar ligges users encapsulate({
# Search a list for all function objects, change the environment for those
# functions to a target environment, and return the modified list.
assign_func_envs <- function(objs, target_env) {
if (is.null(target_env)) return(objs)
lapply(objs, function(x) {
if (is.function(x)) environment(x) <- target_env
x
})
}
# Get names of all superclasses
get_superclassnames <- function(inherit) {
if (is.null(inherit)) return(NULL)
c(inherit$classname, get_superclassnames(inherit$get_inherit()))
}
# Wrapper around list2env with a NULL check. In R <3.2.0, if an empty unnamed
# list is passed to list2env(), it errors. But an empty named list is OK. For
# R >=3.2.0, this wrapper is not necessary.
# @param empty_to_null Controls what to do when x is NULL or empty list.
# If TRUE, return NULL. If FALSE, return an empty list.
list2env2 <- function(x, envir = NULL, parent = emptyenv(),
hash = (length(x) > 100),
size = max(29L, length(x)),
empty_to_null = TRUE) {
if (is.null(envir)) {
envir <- new.env(hash = hash, parent = parent, size = size)
}
if (length(x) == 0) {
if (empty_to_null)
return(NULL)
else
return(envir)
}
list2env(x, envir)
}
})
R6/R/clone.R 0000644 0001762 0000144 00000026761 14752476063 012217 0 ustar ligges users # This function will be added as a method to R6 objects, with the name 'clone',
# and with the environment changed.
generator_funs$clone_method <- function(deep = FALSE) {
# Need to embed these utility functions inside this closure because the
# environment of this function will change.
# This takes a list of objects and a list of pairs of environments. For each
# object, if it is a function, this checks if that function's environment is
# the same as any of the `old` members of the pairs; if so, it will change
# the function's environment to the matching `new` member. If the function's
# environment is not found in the list, then it will not be touched.
remap_func_envs <- function(objs, old_new_env_pairs) {
lapply(objs, function(x) {
if (is.function(x)) {
func_env <- environment(x)
for (i in seq_along(old_new_env_pairs)) {
if (identical(func_env, old_new_env_pairs[[i]]$old)) {
environment(x) <- old_new_env_pairs[[i]]$new
break
}
}
}
x
})
}
list2env2 <- function(x, envir = NULL, parent = emptyenv(),
hash = (length(x) > 100),
size = max(29L, length(x)),
empty_to_null = TRUE) {
if (is.null(envir)) {
envir <- new.env(hash = hash, parent = parent, size = size)
}
if (length(x) == 0) {
if (empty_to_null)
return(NULL)
else
return(envir)
}
list2env(x, envir)
}
# ---------------------------------------------------------------------------
# Create representation of the old object
# ---------------------------------------------------------------------------
old <- list(
list(
enclosing = .subset2(self, ".__enclos_env__"),
binding = self, # AKA the public binding environment
private = NULL
)
)
if (!is.environment(old[[1]]$enclosing)) {
stop("clone() must be called from an R6 object.")
}
old[[1]]$private <- old[[1]]$enclosing$private
has_private <- !is.null(old[[1]]$private)
# Figure out if we're in a portable class object
portable <- !identical(old[[1]]$binding, old[[1]]$enclosing)
# Traverse the super binding and enclosing environments, and add them to the
# list.
i <- 1
while (TRUE) {
if (is.null(old[[i]]$enclosing$super)) {
break
}
old[[i+1]] <- list(
binding = old[[i]]$enclosing$super,
enclosing = old[[i]]$enclosing$super$.__enclos_env__
)
i <- i + 1
}
# Set up stuff for deep clones
if (deep) {
if (has_private && is.function(old[[1]]$private$deep_clone)) {
# Get private$deep_clone, if available.
deep_clone <- old[[1]]$private$deep_clone
} else {
# If there's no private$deep_clone, then this default function will copy
# fields that are R6 objects.
deep_clone <- function(name, value) {
# Check if it's an R6 object.
is_r6_object <- is.environment(value) &&
!is.null(get0(".__enclos_env__", value, inherits = FALSE))
if (is_r6_object) {
return(value$clone(deep = TRUE))
}
value
}
}
}
# We'll use these a lot later, and it's faster to refer to them directly.
old_1_binding <- old[[1]]$binding
old_1_private <- old[[1]]$private
# ---------------------------------------------------------------------------
# Create representation of the new object
# ---------------------------------------------------------------------------
# The object representation is made up of a list of "slices". Each slice
# represents one level of inheritance. The first slice is somewhat different
# from subsequent ones. The later ones are superclass slices. They do not
# have a separate `private` environment.
# Create the first slice. This one is different from the others.
make_first_new_slice <- function(old_slice, portable) {
new_slice <- list(
enclosing = NULL,
binding = NULL
)
has_private <- !is.null(old_slice$private)
if (portable) {
enclosing_parent <- parent.env(old_slice$enclosing)
binding_parent <- emptyenv()
if (has_private) {
private_parent <- emptyenv()
new_slice$private <- new.env(private_parent, hash = FALSE)
}
new_slice$binding <- new.env(binding_parent, hash = FALSE)
new_slice$enclosing <- new.env(enclosing_parent, hash = FALSE)
} else {
if (has_private) {
private_parent <- parent.env(old_slice$private)
new_slice$private <- new.env(private_parent, hash = FALSE)
binding_parent <- new_slice$private
new_slice$binding <- new.env(binding_parent, hash = FALSE)
} else {
binding_parent <- parent.env(old_slice$binding)
new_slice$binding <- new.env(binding_parent, hash = FALSE)
}
new_slice$enclosing <- new_slice$binding
}
# Set up self, private, and .__enclos_env__
new_slice$enclosing$self <- new_slice$binding
if (has_private) {
new_slice$enclosing$private <- new_slice$private
}
new_slice$binding$.__enclos_env__ <- new_slice$enclosing
new_slice
}
# This creates a slice other than the first one.
make_new_slice <- function(old_slice, self, private, enclosing_parent) {
enclosing <- new.env(enclosing_parent, hash = FALSE)
binding <- new.env(emptyenv(), hash = FALSE)
enclosing$self <- self
if (!is.null(private)) {
enclosing$private <- private
}
binding$.__enclos_env__ <- enclosing
list(
enclosing = enclosing,
binding = binding
)
}
new <- list(
make_first_new_slice(old[[1]], portable)
)
# We'll use these a lot, and it's faster to refer to them directly.
new_1_binding <- new[[1]]$binding
new_1_private <- new[[1]]$private
new_1_enclosing <- new[[1]]$enclosing
# Mirror the super environments from the old object
if (length(old) > 1) {
for (i in seq.int(2, length(old))) {
if (portable) {
enclosing_parent <- parent.env(old[[i]]$enclosing)
} else {
enclosing_parent <- new_1_enclosing
}
new[[i]] <- make_new_slice(
old[[i]],
new_1_binding,
new_1_private,
enclosing_parent
)
}
# A second pass to add in the `super` to each enclosing environment.
for (i in seq.int(1, length(old)-1)) {
new[[i]]$enclosing$super <- new[[i+1]]$binding
}
}
# ---------------------------------------------------------------------------
# Copy members from old to new
# ---------------------------------------------------------------------------
copy_slice <- function(old_slice, new_slice, old_new_enclosing_pairs, first_slice = FALSE) {
# Copy the old objects, fix up method environments, and put them into the
# new binding environment.
# Separate active and non-active bindings. We'll copy over just the
# non-active bindings now; the active bindings need to be copied over with
# a different method later.
binding_names <- ls(old_slice$binding, all.names = TRUE)
if (!is.null(old_slice$enclosing$`.__active__`)) {
binding_names <- setdiff(binding_names, names(old_slice$enclosing$`.__active__`))
}
binding_copies <- mget(binding_names, envir = old_slice$binding)
# Don't copy self, private, super, or .__enclos_env__. Note that using
# %in% is significantly faster than setdiff() here.
keep_idx <- !(names(binding_copies) %in% c("self", "private", "super", ".__enclos_env__"))
binding_copies <- binding_copies[keep_idx]
binding_copies <- remap_func_envs(binding_copies, old_new_enclosing_pairs)
if (deep) {
binding_copies <- mapply(
deep_clone,
names(binding_copies),
binding_copies,
SIMPLIFY = FALSE
)
}
# Copy in public bindings
list2env2(binding_copies, new_slice$binding)
# Now copy over active bindings, if present
if (!is.null(old_slice$enclosing$`.__active__`)) {
active_copies <- remap_func_envs(old_slice$enclosing$`.__active__`, old_new_enclosing_pairs)
for (name in names(active_copies)) {
makeActiveBinding(name, active_copies[[name]], new_slice$binding)
}
new_slice$enclosing$`.__active__` <- active_copies
}
# Copy private members
if (!is.null(old_slice$private)) {
private_copies <- as.list.environment(old_slice$private, all.names = TRUE)
if (deep) {
private_copies <- mapply(
deep_clone,
names(private_copies),
private_copies,
SIMPLIFY = FALSE
)
}
private_copies <- remap_func_envs(private_copies, old_new_enclosing_pairs)
list2env2(private_copies, new_slice$private)
}
# With the first slice, lock the methods. For other slices, there's no
# need to lock lock methods because they're not publicly accessible.
if (first_slice) {
# A list of the possible environments for methods.
method_envs <- lapply(old_new_enclosing_pairs, `[[`, "new")
# Returns TRUE if the object is a method (or active binding), FALSE
# otherwise. Functions that are not methods result in FALSE.
is_method <- function(f, method_envs) {
env <- environment(f)
for (i in seq_along(method_envs)) {
if (identical(env, method_envs[[i]])) {
return(TRUE)
}
}
FALSE
}
for (name in names(binding_copies)) {
if (is_method(new_slice$binding[[name]], method_envs))
lockBinding(name, new_slice$binding)
}
if (has_private) {
for (name in names(private_copies)) {
if (is_method(new_slice$private[[name]], method_envs))
lockBinding(name, new_slice$private)
}
}
}
}
old_new_enclosing_pairs <- list()
for (i in seq_along(old)) {
old_new_enclosing_pairs[[i]] <- list(
old = old[[i]]$enclosing,
new = new[[i]]$enclosing
)
}
for (i in seq_along(old)) {
# Only need to pass along the old/new pairs from i and above, because a
# superclass's function will never have an enclosing environment from a
# subclass.
copy_slice(
old[[i]],
new[[i]],
old_new_enclosing_pairs[seq.int(i, length(old))],
(i == 1)
)
}
# Lock --------------------------------------------------------------
# Copy locked state of environment
if (environmentIsLocked(old_1_binding)) {
lockEnvironment(new_1_binding)
}
if (has_private && environmentIsLocked(old_1_private)) {
lockEnvironment(new_1_private)
}
# Finalizer -------------------------------------------------------
if (is.function(.subset2(new_1_binding, "finalize"))) {
# This wraps the user's `finalize` method. The user's finalize method
# typically does not have an `e` argument, so the wrapper needs to consume
# the `e` argument.
finalizer_wrapper <- function(e) {
.subset2(e, "finalize")()
}
# Reassign the wrapper's environment so that it does not capture the current
# environment and prevent objects from getting GC'd.
environment(finalizer_wrapper) <- baseenv()
reg.finalizer(
new_1_binding,
finalizer_wrapper,
onexit = TRUE
)
}
if (has_private) {
if (is.function(.subset2(new_1_private, "finalize"))) {
finalizer_wrapper <- function(e) {
.subset2(e, ".__enclos_env__")$private$finalize()
}
environment(finalizer_wrapper) <- baseenv()
reg.finalizer(
new_1_binding,
finalizer_wrapper,
onexit = TRUE
)
}
}
class(new_1_binding) <- class(old_1_binding)
new_1_binding
}
R6/R/r6_class.R 0000644 0001762 0000144 00000043275 14753731055 012626 0 ustar ligges users #' Create an R6 reference object generator
#'
#' R6 objects are essentially environments, structured in a way that makes them
#' look like an object in a more typical object-oriented language than R. They
#' support public and private members, as well as inheritance across different
#' packages.
#'
#' An R6 object consists of a public environment, and may also contain a private
#' environment, as well as environments for superclasses. In one sense, the
#' object and the public environment are the same; a reference to the object is
#' identical to a reference to the public environment. But in another sense, the
#' object also consists of the fields, methods, private environment and so on.
#'
#' The \code{active} argument is a list of active binding functions. These
#' functions take one argument. They look like regular variables, but when
#' accessed, a function is called with an optional argument. For example, if
#' \code{obj$x2} is an active binding, then when accessed as \code{obj$x2}, it
#' calls the \code{x2()} function that was in the \code{active} list, with no
#' arguments. However, if a value is assigned to it, as in \code{obj$x2 <- 50},
#' then the function is called with the right-side value as its argument, as in
#' \code{x2(50)}. See \code{\link{makeActiveBinding}} for more information.
#'
#' If the public or private lists contain any items that have reference
#' semantics (for example, an environment), those items will be shared across
#' all instances of the class. To avoid this, add an entry for that item with a
#' \code{NULL} initial value, and then in the \code{initialize} method,
#' instantiate the object and assign it.
#'
#' @section The \code{print} method:
#'
#' R6 object generators and R6 objects have a default \code{print} method to
#' show them on the screen: they simply list the members and parameters (e.g.
#' lock_objects, portable, etc., see above) of the object.
#'
#' The default \code{print} method of R6 objects can be redefined, by
#' supplying a public \code{print} method. (\code{print} members that are not
#' functions are ignored.) This method is automatically called whenever the
#' object is printed, e.g. when the object's name is typed at the command
#' prompt, or when \code{print(obj)} is called. It can also be called directly
#' via \code{obj$print()}. All extra arguments from a \code{print(obj, ...)}
#' call are passed on to the \code{obj$print(...)} method.
#'
#' @section Portable and non-portable classes:
#'
#' When R6 classes are portable (the default), they can be inherited across
#' packages without complication. However, when in portable mode, members must
#' be accessed with \code{self} and \code{private}, as in \code{self$x} and
#' \code{private$y}.
#'
#' When used in non-portable mode, R6 classes behave more like reference
#' classes: inheritance across packages will not work well, and \code{self}
#' and \code{private} are not necessary for accessing fields.
#'
#' @section Cloning objects:
#'
#' R6 objects have a method named \code{clone} by default. To disable this,
#' use \code{cloneable=FALSE}. Having the \code{clone} method present will
#' slightly increase the memory footprint of R6 objects, but since the method
#' will be shared across all R6 objects, the memory use will be negligible.
#'
#' By default, calling \code{x$clone()} on an R6 object will result in a
#' shallow clone. That is, if any fields have reference semantics
#' (environments, R6, or reference class objects), they will not be copied;
#' instead, the clone object will have a field that simply refers to the same
#' object.
#'
#' To make a deep copy, you can use \code{x$clone(deep=TRUE)}. With this
#' option, any fields that are R6 objects will also be cloned; however,
#' environments and reference class objects will not be.
#'
#' If you want different deep copying behavior, you can supply your own
#' private method called \code{deep_clone}. This method will be called for
#' each field in the object, with two arguments: \code{name}, which is the
#' name of the field, and \code{value}, which is the value. Whatever the
#' method returns will be used as the value for the field in the new clone
#' object. You can write a \code{deep_clone} method that makes copies of
#' specific fields, whether they are environments, R6 objects, or reference
#' class objects.
#'
#' @section S3 details:
#'
#' Normally the public environment will have two classes: the one supplied in
#' the \code{classname} argument, and \code{"R6"}. It is possible to get the
#' public environment with no classes, by using \code{class=FALSE}. This will
#' result in faster access speeds by avoiding class-based dispatch of
#' \code{$}. The benefit is negligible in most cases.
#'
#' If a class is a subclass of another, the object will have as its classes
#' the \code{classname}, the superclass's \code{classname}, and \code{"R6"}
#'
#' The primary difference in behavior when \code{class=FALSE} is that, without
#' a class attribute, it won't be possible to use S3 methods with the objects.
#' So, for example, pretty printing (with \code{print.R6Class}) won't be used.
#'
#' @aliases R6
#' @export
#' @param classname Name of the class. The class name is useful primarily for S3
#' method dispatch.
#' @param public A list of public members, which can be functions (methods) and
#' non-functions (fields).
#' @param private An optional list of private members, which can be functions
#' and non-functions.
#' @param active An optional list of active binding functions.
#' @param inherit A R6ClassGenerator object to inherit from; in other words, a
#' superclass. This is captured as an unevaluated expression which is
#' evaluated in \code{parent_env} each time an object is instantiated.
#' @param portable If \code{TRUE} (the default), this class will work with
#' inheritance across different packages. Note that when this is enabled,
#' fields and members must be accessed with \code{self$x} or
#' \code{private$x}; they can't be accessed with just \code{x}.
#' @param parent_env An environment to use as the parent of newly-created
#' objects.
#' @param class Should a class attribute be added to the object? Default is
#' \code{TRUE}. If \code{FALSE}, the objects will simply look like
#' environments, which is what they are.
#' @param lock_objects Should the environments of the generated objects be
#' locked? If locked, new members can't be added to the objects.
#' @param lock_class If \code{TRUE}, it won't be possible to add more members to
#' the generator object with \code{$set}. If \code{FALSE} (the default), then
#' it will be possible to add more members with \code{$set}. The methods
#' \code{$is_locked}, \code{$lock}, and \code{$unlock} can be used to query
#' and change the locked state of the class.
#' @param cloneable If \code{TRUE} (the default), the generated objects will
#' have method named \code{$clone}, which makes a copy of the object.
#' @examples
#' # A queue ---------------------------------------------------------
#' 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()
#' #> [1] 5
#' q$remove()
#' #> [1] 6
#'
#' # Private members can't be accessed directly
#' q$queue
#' #> NULL
#' # q$length()
#' #> Error: attempt to apply non-function
#'
#' # add() returns self, so it can be chained
#' q$add(10)$add(11)$add(12)
#'
#' # remove() returns the value removed, so it's not chainable
#' q$remove()
#' #> [1] "foo"
#' q$remove()
#' #> [1] "something"
#' q$remove()
#' #> [1] "another thing"
#' q$remove()
#' #> [1] 17
#'
#'
#' # Active bindings -------------------------------------------------
#' 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
#' #> [1] 100
#' n$x2
#' #> [1] 200
#' n$x2 <- 1000
#' n$x
#' #> [1] 500
#'
#' # If the function takes no arguments, it's not possible to use it with <-:
#' n$rand
#' #> [1] 0.2648
#' n$rand
#' #> [1] 2.171
#' # n$rand <- 3
#' #> Error: unused argument (quote(3))
#'
#'
#' # Inheritance -----------------------------------------------------
#' # 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()
#' #> Next item is at index 1
#' #> 1: 5
#' #> 2: 6
#' #> 3: foo
#' hq$remove()
#' #> [1] 5
#' hq$show()
#' #> Next item is at index 2
#' #> 1: 5
#' #> 2: 6
#' #> 3: foo
#' hq$remove()
#' #> [1] 6
#'
#'
#'
#' # Calling superclass methods with super$ --------------------------
#' 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()
#' #> [1] 2
#' cq$add("z")
#' cq$remove()
#' #> [1] "x"
#' cq$remove()
#' #> [1] "y"
#' cq$get_total()
#' #> [1] 3
#'
#'
#' # Non-portable classes --------------------------------------------
#' # By default, R6 classes are portable, which means they can be inherited
#' # across different packages. Portable classes require using self$ and
#' # private$ to access members.
#' # When used in non-portable mode, members can be accessed without self$,
#' # and assignments can be made with <<-.
#'
#' 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()
#' #> [1] 10
#'
#' # Setting new values ----------------------------------------------
#' # It is possible to add new members to the class after it has been created,
#' # by using the $set() method on the generator.
#'
#' Simple <- R6Class("Simple",
#' public = list(
#' x = 1,
#' getx = function() self$x
#' )
#' )
#'
#' Simple$set("public", "getx2", function() self$x*2)
#'
#' # Use overwrite = TRUE to overwrite existing values
#' Simple$set("public", "x", 10, overwrite = TRUE)
#'
#' s <- Simple$new()
#' s$x
#' s$getx2()
#'
#'
#' # Cloning objects -------------------------------------------------
#' a <- Queue$new(5, 6)
#' a$remove()
#' #> [1] 5
#'
#' # Clone a. New object gets a's state.
#' b <- a$clone()
#'
#' # Can add to each queue separately now.
#' a$add(10)
#' b$add(20)
#'
#' a$remove()
#' #> [1] 6
#' a$remove()
#' #> [1] 10
#'
#' b$remove()
#' #> [1] 6
#' b$remove()
#' #> [1] 20
#'
#'
#' # Deep clones -----------------------------------------------------
#'
#'Simple <- R6Class("Simple",
#' public = list(
#' x = NULL,
#' initialize = function(val) self$x <- val
#' )
#')
#'
#' Cloner <- R6Class("Cloner",
#' public = list(
#' s = NULL,
#' y = 1,
#' initialize = function() self$s <- Simple$new(1)
#' )
#' )
#'
#' a <- Cloner$new()
#' b <- a$clone()
#' c <- a$clone(deep = TRUE)
#'
#' # Modify a
#' a$s$x <- 2
#' a$y <- 2
#'
#' # b is a shallow clone. b$s is the same as a$s because they are R6 objects.
#' b$s$x
#' #> [1] 2
#' # But a$y and b$y are different, because y is just a value.
#' b$y
#' #> [1] 1
#'
#' # c is a deep clone, so c$s is not the same as a$s.
#' c$s$x
#' #> [1] 1
#' c$y
#' #> [1] 1
#'
#'
#' # Deep clones with custom deep_clone method -----------------------
#'
#' CustomCloner <- R6Class("CustomCloner",
#' public = list(
#' e = NULL,
#' s1 = NULL,
#' s2 = NULL,
#' s3 = NULL,
#' initialize = function() {
#' self$e <- new.env(parent = emptyenv())
#' self$e$x <- 1
#' self$s1 <- Simple$new(1)
#' self$s2 <- Simple$new(1)
#' self$s3 <- Simple$new(1)
#' }
#' ),
#' private = list(
#' # When x$clone(deep=TRUE) is called, the deep_clone gets invoked once for
#' # each field, with the name and value.
#' deep_clone = function(name, value) {
#' if (name == "e") {
#' # e1 is an environment, so use this quick way of copying
#' list2env(as.list.environment(value, all.names = TRUE),
#' parent = emptyenv())
#'
#' } else if (name %in% c("s1", "s2")) {
#' # s1 and s2 are R6 objects which we can clone
#' value$clone()
#'
#' } else {
#' # For everything else, just return it. This results in a shallow
#' # copy of s3.
#' value
#' }
#' }
#' )
#' )
#'
#' a <- CustomCloner$new()
#' b <- a$clone(deep = TRUE)
#'
#' # Change some values in a's fields
#' a$e$x <- 2
#' a$s1$x <- 3
#' a$s2$x <- 4
#' a$s3$x <- 5
#'
#' # b has copies of e, s1, and s2, but shares the same s3
#' b$e$x
#' #> [1] 1
#' b$s1$x
#' #> [1] 1
#' b$s2$x
#' #> [1] 1
#' b$s3$x
#' #> [1] 5
#'
#'
#' # Debugging -------------------------------------------------------
#' \dontrun{
#' # This will enable debugging the getx() method for objects of the 'Simple'
#' # class that are instantiated in the future.
#' Simple$debug("getx")
#' s <- Simple$new()
#' s$getx()
#'
#' # Disable debugging for future instances:
#' Simple$undebug("getx")
#' s <- Simple$new()
#' s$getx()
#'
#' # To enable and disable debugging for a method in a single instance of an
#' # R6 object (this will not affect other objects):
#' s <- Simple$new()
#' debug(s$getx)
#' s$getx()
#' undebug(s$getx)
#' }
# This function is encapsulated so that it is bound in the R6 namespace, but
# enclosed in the capsule environment
R6Class <- encapsulate(function(classname = NULL, public = list(),
private = NULL, active = NULL,
inherit = NULL, lock_objects = TRUE,
class = TRUE, portable = TRUE,
lock_class = FALSE, cloneable = TRUE,
parent_env = parent.frame()) {
if (!all_named(public) || !all_named(private) || !all_named(active))
stop("All elements of public, private, and active must be named.")
allnames <- c(names(public), names(private), names(active))
if (any(duplicated(allnames)))
stop("All items in public, private, and active must have unique names.")
if ("clone" %in% allnames)
stop("Cannot add a member with reserved name 'clone'.")
if (any(c("self", "private", "super") %in%
c(names(public), names(private), names(active))))
stop("Items cannot use reserved names 'self', 'private', and 'super'.")
if ("initialize" %in% c(names(private), names(active)))
stop("'initialize' is not allowed in private or active.")
if (length(get_nonfunctions(active)) != 0)
stop("All items in active must be functions.")
# Create the generator object, which is an environment
generator <- new.env(parent = capsule)
generator$self <- generator
# Set the generator functions to eval in the generator environment, and copy
# them into the generator env.
generator_funs <- assign_func_envs(generator_funs, generator)
list2env2(generator_funs, generator)
generator$classname <- classname
generator$active <- active
generator$portable <- portable
generator$cloneable <- cloneable
generator$parent_env <- parent_env
generator$lock_objects <- lock_objects
generator$class <- class
generator$lock_class <- lock_class
# Separate fields from methods
generator$public_fields <- get_nonfunctions(public)
generator$private_fields <- get_nonfunctions(private)
generator$public_methods <- get_functions(public)
generator$private_methods <- get_functions(private)
if (cloneable)
generator$public_methods$clone <- generator_funs$clone_method
# Capture the unevaluated expression for the superclass; when evaluated in
# the parent_env, it should return the superclass object.
generator$inherit <- substitute(inherit)
# Names of methods for which to enable debugging
generator$debug_names <- character(0)
attr(generator, "name") <- paste0(classname, "_generator")
class(generator) <- "R6ClassGenerator"
# Print message; in a future version, this will be upgraded to a warning.
if ("finalize" %in% names(generator$public_methods)) {
message(
"R6Class ", classname,
": finalize() method is public, but it should be private as of R6 2.4.0. ",
"This code will continue to work, but in a future version of R6, ",
"finalize() will be required to be private."
)
}
generator
})
#' @exportS3Method utils::.DollarNames
.DollarNames.R6 <- function(x, pattern) {
names <- ls(x, all.names = TRUE)
names <- names[grepl(pattern, names)]
setdiff(names, c(".__enclos_env__", "initialize"))
}
R6/NAMESPACE 0000644 0001762 0000144 00000000421 14752476063 011773 0 ustar ligges users # Generated by roxygen2: do not edit by hand
S3method(as.list,R6)
S3method(format,R6)
S3method(format,R6ClassGenerator)
S3method(plot,R6)
S3method(print,R6)
S3method(print,R6ClassGenerator)
S3method(utils::.DollarNames,R6)
export(R6Class)
export(is.R6)
export(is.R6Class)
R6/LICENSE 0000644 0001762 0000144 00000000050 14752476063 011557 0 ustar ligges users YEAR: 2024
COPYRIGHT HOLDER: R6 authors
R6/NEWS.md 0000644 0001762 0000144 00000014666 14753731102 011657 0 ustar ligges users R6 2.6.1
========
* Closed #298: In `.DollarNames.R6()`, avoid use of `NextMethod()`. This is to work around a compatibility issue with RStudio IDE. (#299)
R6 2.6.0
========
* R6 methods no longer recommends `initialize` or `.__enclos_env__` in autocomplete.
* The deprecated `lock` parameter has been removed.
* `R6Class()` now prints a message when a `finalize` method is public instead of private.
* When a superclass is not cloneable, then subclasses cannot be cloneable (@IndrajeetPatil, #247).
* Fixed #253: Errors could occur when deep cloning if a member object was an environment with a class that had a `$` method. Deep cloning now uses `get0()` instead of `$`. R6 now requires R >= 3.2. (@zeehio, #274)
R6 2.5.1
========
* Removed unused packages from `Suggests` section in DESCRIPTION.
R6 2.5.0
========
* Resolved #195: Slightly clearer message when there is an error in the `initialize()` method.
* Fixed #214: When a non-portable object inheritance was cloned, methods that were inherited (and not overridden) had the wrong environment. (#215, #217)
* Printing R6 objects, no longer includes `.__active__`.
R6 2.4.1
========
* Cloning active bindings previously relied on buggy behavior in `as.list.environment()`, which would return the active binding's function definition rather than the value from invoking the function. In R 4.0, the behavior will chang so that it returns the value. R6 now no longer relies on this buggy behavior. (#192)
R6 2.4.0
========
* Fixed #146: Finalizers can now be private methods. (#181)
* Fixed #167: Finalizers now run on cloned objects. (#180)
R6 2.3.0
========
* Vignettes are no longer included as part of the source package because of their large size. Documentation is now at https://r6.r-lib.org/.
* Fixed #125: The `print.R6` method now always returns the object that was passed to it.
* Fixed #155: In some cases, a cloned object's methods could refer to the wrong `super` object. (#156)
* Fixed #94, #133: When cloning an object which contained a function that is *not* a method, the corresponding function in the new object would have its environment changed, as though it were a method. Now it no longer has a changed environment. (#156)
* Fixed #121: If a `finalize` method was present, it would prevent objects passed to `initialize` from getting GC'd.
* Fixed #158: If a `$set` method of an R6 generator object is given the value `NULL`, it previously removed the named item. Now it adds the named item with the value `NULL`.
* Fixed #159: Printing an R6 object containing a large vector was slow.
R6 2.2.2
========
* Fixed #108: When an object with a `super` object and an active binding in the `super` object was cloned, the new object's `super` object did not get the active binding -- it was a normal function.
* Fixed #119: When a class had two levels of inheritance, an instance of that class's `super` object could contain methods that had an incorrect enclosing environment.
R6 2.2.1
========
* Vignettes now only try use the microbenchmark package if it is present. This is so that the package builds properly on platforms where microbenchmark is not present, like Solaris.
* Fixed ending position for `trim()`.
R6 2.2.0
========
* Classes can define finalizers explicitly, by defining a public `finalize` method. (#92, #93)
* Added function `is.R6()` and `is.R6Class()`. (#95)
* Fixed #96: R6 now avoids using `$` and `[[` after the class has been assigned to the object. This allows the user to provide their own methods for `$` and `[[` without causing problems to R6's operation.
R6 2.1.3
========
* The `plot` S3 method for R6 objects will call `$plot` on the object if present. (#77)
* Fixed printing of members that are R6 objects. (#88)
* Fixed deep cloning for non-portable classes. (#85)
* Added `as.list.R6` method. (#91)
R6 2.1.2
========
* Implemented `format.R6()` and `format.R6ClassGenerator`, the former calls a public `format` method if defined. This might change the functionality of existing classes that define a public `format` method intended for other purposes (#73. Thanks to Kirill Müller)
* Functions are shown with their interface in `print` and `format`, limited to one line (#76. Thanks to Kirill Müller)
* R6 objects and generators print out which class they inherit from. (#67)
R6 2.1.1
========
* Fixed a bug with printing R6 objects when a `[[` method is defined for the class. (#70)
* Fixed cloning of objects that call a `super` method which accesses `private`. (#72)
R6 2.1.0
========
* Added support for making clones of R6 objects with a `clone()` method on R6 objects. The `deep=TRUE` option allows for making clones that have copies of fields with reference semantics (like other R6 objects). (#27)
* Allow adding public or private members when there were no public or private members to begin with. (#51)
* Previously, when an R6 object was printed, it accessed (and called) active bindings. Now it simply reports that a field is an active binding. (#37, #38. Thanks to Oscar de Lama)
* Printing private members now works correctly for portable R6 objects. (#26)
* The 'lock' argument has been renamed to 'lock_objects'. Also, there is a new argument, 'lock_class', which can prevent changes to the class. (#52)
* Fixed printing of NULL fields.
R6 2.0.1
========
* A superclass is validated on object instantiation, not on class creation.
* Added `debug` and `undebug` methods to generator object.
R6 2.0
========
* [BREAKING CHANGE] Added `portable` option, which allows inheritance across different package namespaces, and made it the default.
* Added `set()` method on class generator object, so new fields and methods can be added after the generator has been created.
* All of the functions involved in instantiating objects are encapsulated in an environment separate from the R6 namespace. This means that if a generator is created with one version of R6, saved, then restored in a new R session that has a different version of R6, there shouldn't be any problems with compatibility.
* Methods are locked so that they can't be changed. (Fixes #19)
* Inheritance of superclasses is dynamic; instead of reading in the superclass when a class is created, this happens each time an object is instantiated. (Fixes #12)
* Added trailing newline when printing R6 objects. (Thanks to Gabor Csardi)
* The `print` method of R6 objects can be redefined. (Thanks to Gabor Csardi)
R6 1.0.1
========
* First release on CRAN.
* Removed pryr from suggested packages.
R6 1.0
========
* First release
R6/README.md 0000644 0001762 0000144 00000004342 14752476063 012041 0 ustar ligges users R6: Encapsulated object-oriented programming for R
==================================================
[](https://github.com/r-lib/R6/actions)
R6 is an implementation of encapsulated object-oriented programming for R, and is a simpler, faster, lighter-weight alternative to R's built-in reference classes. This style of programming is also sometimes referred to as classical object-oriented programming.
Some features of R6:
* R6 objects have reference semantics.
* R6 cleanly supports inheritance across packages.
* R6 classes have public and private members.
In contrast to R's reference classes, R6 is not built on the S4 class system, so it does not require the *methods* package. Unlike reference classes, R6 classes can be cleanly inherited across different packages.
See the [Introduction](https://r6.r-lib.org/articles/Introduction.html) article for usage examples.
## Installation
To install R6 from CRAN:
```R
install.packages('R6')
```
To install the development version (requires the devtools package):
```R
devtools::install_github('r-lib/R6', build_vignettes = FALSE)
```
## Documentation
* [Introduction to R6](https://r6.r-lib.org/articles/Introduction.html)
* [Debugging methods in R6 objects](https://r6.r-lib.org/articles/Debugging.html)
* [Performance tests](https://r6.r-lib.org/articles/Performance.html) - Speed and memory comparisons of R6 classes and reference classes.
* [Portable R6 classes](https://r6.r-lib.org/articles/Portable.html) - Inheritance across different packages.
### Why R6?
Why the name R6? When R's reference classes were introduced, some users, following the names of R's existing class systems S3 and S4, called the new class system R5 in jest. Although reference classes are not actually called R5, the name of this package and its classes takes inspiration from that name.
The name R5 was also a code-name used for a different object system started by Simon Urbanek, meant to solve some issues with S4 relating to syntax and performance. However, the R5 branch was shelved after a little development, and it was never released.
R6/man/ 0000755 0001762 0000144 00000000000 14752476063 011332 5 ustar ligges users R6/man/R6Class.Rd 0000644 0001762 0000144 00000033122 14752476063 013077 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/r6_class.R
\name{R6Class}
\alias{R6Class}
\alias{R6}
\title{Create an R6 reference object generator}
\usage{
R6Class(
classname = NULL,
public = list(),
private = NULL,
active = NULL,
inherit = NULL,
lock_objects = TRUE,
class = TRUE,
portable = TRUE,
lock_class = FALSE,
cloneable = TRUE,
parent_env = parent.frame()
)
}
\arguments{
\item{classname}{Name of the class. The class name is useful primarily for S3
method dispatch.}
\item{public}{A list of public members, which can be functions (methods) and
non-functions (fields).}
\item{private}{An optional list of private members, which can be functions
and non-functions.}
\item{active}{An optional list of active binding functions.}
\item{inherit}{A R6ClassGenerator object to inherit from; in other words, a
superclass. This is captured as an unevaluated expression which is
evaluated in \code{parent_env} each time an object is instantiated.}
\item{lock_objects}{Should the environments of the generated objects be
locked? If locked, new members can't be added to the objects.}
\item{class}{Should a class attribute be added to the object? Default is
\code{TRUE}. If \code{FALSE}, the objects will simply look like
environments, which is what they are.}
\item{portable}{If \code{TRUE} (the default), this class will work with
inheritance across different packages. Note that when this is enabled,
fields and members must be accessed with \code{self$x} or
\code{private$x}; they can't be accessed with just \code{x}.}
\item{lock_class}{If \code{TRUE}, it won't be possible to add more members to
the generator object with \code{$set}. If \code{FALSE} (the default), then
it will be possible to add more members with \code{$set}. The methods
\code{$is_locked}, \code{$lock}, and \code{$unlock} can be used to query
and change the locked state of the class.}
\item{cloneable}{If \code{TRUE} (the default), the generated objects will
have method named \code{$clone}, which makes a copy of the object.}
\item{parent_env}{An environment to use as the parent of newly-created
objects.}
}
\description{
R6 objects are essentially environments, structured in a way that makes them
look like an object in a more typical object-oriented language than R. They
support public and private members, as well as inheritance across different
packages.
}
\details{
An R6 object consists of a public environment, and may also contain a private
environment, as well as environments for superclasses. In one sense, the
object and the public environment are the same; a reference to the object is
identical to a reference to the public environment. But in another sense, the
object also consists of the fields, methods, private environment and so on.
The \code{active} argument is a list of active binding functions. These
functions take one argument. They look like regular variables, but when
accessed, a function is called with an optional argument. For example, if
\code{obj$x2} is an active binding, then when accessed as \code{obj$x2}, it
calls the \code{x2()} function that was in the \code{active} list, with no
arguments. However, if a value is assigned to it, as in \code{obj$x2 <- 50},
then the function is called with the right-side value as its argument, as in
\code{x2(50)}. See \code{\link{makeActiveBinding}} for more information.
If the public or private lists contain any items that have reference
semantics (for example, an environment), those items will be shared across
all instances of the class. To avoid this, add an entry for that item with a
\code{NULL} initial value, and then in the \code{initialize} method,
instantiate the object and assign it.
}
\section{The \code{print} method}{
R6 object generators and R6 objects have a default \code{print} method to
show them on the screen: they simply list the members and parameters (e.g.
lock_objects, portable, etc., see above) of the object.
The default \code{print} method of R6 objects can be redefined, by
supplying a public \code{print} method. (\code{print} members that are not
functions are ignored.) This method is automatically called whenever the
object is printed, e.g. when the object's name is typed at the command
prompt, or when \code{print(obj)} is called. It can also be called directly
via \code{obj$print()}. All extra arguments from a \code{print(obj, ...)}
call are passed on to the \code{obj$print(...)} method.
}
\section{Portable and non-portable classes}{
When R6 classes are portable (the default), they can be inherited across
packages without complication. However, when in portable mode, members must
be accessed with \code{self} and \code{private}, as in \code{self$x} and
\code{private$y}.
When used in non-portable mode, R6 classes behave more like reference
classes: inheritance across packages will not work well, and \code{self}
and \code{private} are not necessary for accessing fields.
}
\section{Cloning objects}{
R6 objects have a method named \code{clone} by default. To disable this,
use \code{cloneable=FALSE}. Having the \code{clone} method present will
slightly increase the memory footprint of R6 objects, but since the method
will be shared across all R6 objects, the memory use will be negligible.
By default, calling \code{x$clone()} on an R6 object will result in a
shallow clone. That is, if any fields have reference semantics
(environments, R6, or reference class objects), they will not be copied;
instead, the clone object will have a field that simply refers to the same
object.
To make a deep copy, you can use \code{x$clone(deep=TRUE)}. With this
option, any fields that are R6 objects will also be cloned; however,
environments and reference class objects will not be.
If you want different deep copying behavior, you can supply your own
private method called \code{deep_clone}. This method will be called for
each field in the object, with two arguments: \code{name}, which is the
name of the field, and \code{value}, which is the value. Whatever the
method returns will be used as the value for the field in the new clone
object. You can write a \code{deep_clone} method that makes copies of
specific fields, whether they are environments, R6 objects, or reference
class objects.
}
\section{S3 details}{
Normally the public environment will have two classes: the one supplied in
the \code{classname} argument, and \code{"R6"}. It is possible to get the
public environment with no classes, by using \code{class=FALSE}. This will
result in faster access speeds by avoiding class-based dispatch of
\code{$}. The benefit is negligible in most cases.
If a class is a subclass of another, the object will have as its classes
the \code{classname}, the superclass's \code{classname}, and \code{"R6"}
The primary difference in behavior when \code{class=FALSE} is that, without
a class attribute, it won't be possible to use S3 methods with the objects.
So, for example, pretty printing (with \code{print.R6Class}) won't be used.
}
\examples{
# A queue ---------------------------------------------------------
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()
#> [1] 5
q$remove()
#> [1] 6
# Private members can't be accessed directly
q$queue
#> NULL
# q$length()
#> Error: attempt to apply non-function
# add() returns self, so it can be chained
q$add(10)$add(11)$add(12)
# remove() returns the value removed, so it's not chainable
q$remove()
#> [1] "foo"
q$remove()
#> [1] "something"
q$remove()
#> [1] "another thing"
q$remove()
#> [1] 17
# Active bindings -------------------------------------------------
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
#> [1] 100
n$x2
#> [1] 200
n$x2 <- 1000
n$x
#> [1] 500
# If the function takes no arguments, it's not possible to use it with <-:
n$rand
#> [1] 0.2648
n$rand
#> [1] 2.171
# n$rand <- 3
#> Error: unused argument (quote(3))
# Inheritance -----------------------------------------------------
# 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()
#> Next item is at index 1
#> 1: 5
#> 2: 6
#> 3: foo
hq$remove()
#> [1] 5
hq$show()
#> Next item is at index 2
#> 1: 5
#> 2: 6
#> 3: foo
hq$remove()
#> [1] 6
# Calling superclass methods with super$ --------------------------
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()
#> [1] 2
cq$add("z")
cq$remove()
#> [1] "x"
cq$remove()
#> [1] "y"
cq$get_total()
#> [1] 3
# Non-portable classes --------------------------------------------
# By default, R6 classes are portable, which means they can be inherited
# across different packages. Portable classes require using self$ and
# private$ to access members.
# When used in non-portable mode, members can be accessed without self$,
# and assignments can be made with <<-.
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()
#> [1] 10
# Setting new values ----------------------------------------------
# It is possible to add new members to the class after it has been created,
# by using the $set() method on the generator.
Simple <- R6Class("Simple",
public = list(
x = 1,
getx = function() self$x
)
)
Simple$set("public", "getx2", function() self$x*2)
# Use overwrite = TRUE to overwrite existing values
Simple$set("public", "x", 10, overwrite = TRUE)
s <- Simple$new()
s$x
s$getx2()
# Cloning objects -------------------------------------------------
a <- Queue$new(5, 6)
a$remove()
#> [1] 5
# Clone a. New object gets a's state.
b <- a$clone()
# Can add to each queue separately now.
a$add(10)
b$add(20)
a$remove()
#> [1] 6
a$remove()
#> [1] 10
b$remove()
#> [1] 6
b$remove()
#> [1] 20
# Deep clones -----------------------------------------------------
Simple <- R6Class("Simple",
public = list(
x = NULL,
initialize = function(val) self$x <- val
)
)
Cloner <- R6Class("Cloner",
public = list(
s = NULL,
y = 1,
initialize = function() self$s <- Simple$new(1)
)
)
a <- Cloner$new()
b <- a$clone()
c <- a$clone(deep = TRUE)
# Modify a
a$s$x <- 2
a$y <- 2
# b is a shallow clone. b$s is the same as a$s because they are R6 objects.
b$s$x
#> [1] 2
# But a$y and b$y are different, because y is just a value.
b$y
#> [1] 1
# c is a deep clone, so c$s is not the same as a$s.
c$s$x
#> [1] 1
c$y
#> [1] 1
# Deep clones with custom deep_clone method -----------------------
CustomCloner <- R6Class("CustomCloner",
public = list(
e = NULL,
s1 = NULL,
s2 = NULL,
s3 = NULL,
initialize = function() {
self$e <- new.env(parent = emptyenv())
self$e$x <- 1
self$s1 <- Simple$new(1)
self$s2 <- Simple$new(1)
self$s3 <- Simple$new(1)
}
),
private = list(
# When x$clone(deep=TRUE) is called, the deep_clone gets invoked once for
# each field, with the name and value.
deep_clone = function(name, value) {
if (name == "e") {
# e1 is an environment, so use this quick way of copying
list2env(as.list.environment(value, all.names = TRUE),
parent = emptyenv())
} else if (name \%in\% c("s1", "s2")) {
# s1 and s2 are R6 objects which we can clone
value$clone()
} else {
# For everything else, just return it. This results in a shallow
# copy of s3.
value
}
}
)
)
a <- CustomCloner$new()
b <- a$clone(deep = TRUE)
# Change some values in a's fields
a$e$x <- 2
a$s1$x <- 3
a$s2$x <- 4
a$s3$x <- 5
# b has copies of e, s1, and s2, but shares the same s3
b$e$x
#> [1] 1
b$s1$x
#> [1] 1
b$s2$x
#> [1] 1
b$s3$x
#> [1] 5
# Debugging -------------------------------------------------------
\dontrun{
# This will enable debugging the getx() method for objects of the 'Simple'
# class that are instantiated in the future.
Simple$debug("getx")
s <- Simple$new()
s$getx()
# Disable debugging for future instances:
Simple$undebug("getx")
s <- Simple$new()
s$getx()
# To enable and disable debugging for a method in a single instance of an
# R6 object (this will not affect other objects):
s <- Simple$new()
debug(s$getx)
s$getx()
undebug(s$getx)
}
}
R6/man/as.list.R6.Rd 0000644 0001762 0000144 00000000631 14752476063 013464 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/aslist.R
\name{as.list.R6}
\alias{as.list.R6}
\title{Create a list from an R6 object}
\usage{
\method{as.list}{R6}(x, ...)
}
\arguments{
\item{x}{An R6 object.}
\item{...}{Other arguments, which will be ignored.}
}
\description{
This returns a list of public members from the object. It simply calls
\code{as.list.environment}.
}
R6/man/R6-package.Rd 0000644 0001762 0000144 00000002016 14752476406 013501 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/R6-package.R
\docType{package}
\name{R6-package}
\alias{R6-package}
\title{R6: Encapsulated Classes with Reference Semantics}
\description{
\if{html}{\figure{logo.png}{options: style='float: right' alt='logo' width='120'}}
Creates classes with reference semantics, similar to R's built-in reference classes. Compared to reference classes, R6 classes are simpler and lighter-weight, and they are not built on S4 classes so they do not require the methods package. These classes allow public and private members, and they support inheritance, even when the classes are defined in different packages.
}
\seealso{
Useful links:
\itemize{
\item \url{https://r6.r-lib.org}
\item \url{https://github.com/r-lib/R6}
\item Report bugs at \url{https://github.com/r-lib/R6/issues}
}
}
\author{
\strong{Maintainer}: Winston Chang \email{winston@posit.co}
Other contributors:
\itemize{
\item Posit Software, PBC [copyright holder, funder]
}
}
\keyword{internal}
R6/man/figures/ 0000755 0001762 0000144 00000000000 14752476063 012776 5 ustar ligges users R6/man/figures/logo.svg 0000644 0001762 0000144 00000027235 14752476063 014470 0 ustar ligges users
R6/man/figures/logo.png 0000644 0001762 0000144 00000055206 14752476063 014454 0 ustar ligges users PNG
IHDR ޫh gAMA a cHRM z&