R6/0000755000176200001440000000000014107461745010552 5ustar liggesusersR6/NAMESPACE0000644000176200001440000000036013104125424011753 0ustar liggesusers# 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) export(R6Class) export(is.R6) export(is.R6Class) R6/LICENSE0000644000176200001440000000004513104125424011541 0ustar liggesusersYEAR: 2015 COPYRIGHT HOLDER: RStudio R6/README.md0000644000176200001440000000435114103314331012014 0ustar liggesusersR6: Encapsulated object-oriented programming for R ================================================== [![R-CMD-check](https://github.com/r-lib/R6/workflows/R-CMD-check/badge.svg)](https://github.com/r-lib/R6/actions) R6 is an implemention 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/0000755000176200001440000000000014103314331011305 5ustar liggesusersR6/man/R6Class.Rd0000644000176200001440000003324514103314331013060 0ustar liggesusers% 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(), lock ) } \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.} \item{lock}{Deprecated as of version 2.1; use \code{lock_class} instead.} } \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.Rd0000644000176200001440000000063113104125424013442 0ustar liggesusers% 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/figures/0000755000176200001440000000000013745631032012764 5ustar liggesusersR6/man/figures/logo.png0000644000176200001440000005520613745631032014442 0ustar liggesusersPNG  IHDRޫhgAMA a cHRMz&u0`:pQ<bKGD pHYs00ntIME 1YPIDATxwxl_ju[ݲ65B tHBIK I C B U,w[VmW>3?FI׵vvvt99}+3ji~ a/@'t`pp9qx x8 uBDpC%oy1@vP#]JZ;E;*>8RahAPep;c zj B4tGӟPEgps 3SWO# ]@p9)GG0]ks~`xCǿu!`t@z.Aq/{A~VԞԞЅ<nDz 5 Ѕ<\bz7rAp\ٳ"Z[[Ǐqqq̞=3f`3>>["P}>>Zt!]z]p>pp{_SSS()ܞhIKK#// &`2*d <A]C@ ?= (BMM tEQ0L0<Ӄ5\~Uкmq|ChKK ;wdϞ=\EQL69s<>b[]G]G>l~?EyDQvw^hjj{;X4&$$0w\NnG偞j7&qfw@ |e ' "呓hhoӶm 8La shcϺ: 8t>oȄEQ0L8y摚:ն/tb"=ZjhAqq1w玲m؄EQb̙̚5,;Ui[,BB"pAr hhhIhMNNfܹL22!-k WHFV+l~ ISQQ$I#N=2333?>YYY GoD-ZFp; ͯ8퉢(X,&O̼yHJJۢ,EZ .YfU`t& <]m~8nOE!&&Yf1sPlOu3]E5h_AAuuuJh%%%<&NmaYkݶFG : a80FZZf[mуj[|uY]lI!cYh6ͯ{7mqtⷢ MA-M2tܹDW9s>}zl Yclo$EQƼmqLDTߕ JQQQ64ә={`m'1eþ}(,,<6ц&D̙ôiӰZ-iq=l~g8`$Icǎ!6h[ u|' WPPuηնGJJ`moi[OC]m~:Cf[Ԫ- f٩Nbvp<-xcQ{[Q{_p_aa! ΀ m1NۢVCHLt0FۢVmжxT[py6Ũ3666RPPt mqʔ)̝;7kŝCa[<**Q/N_.N 15X*9:lG+-3ja!j,A:t|3Ѷ5vo6E-D旟Oiin6l['%a-ܩNͯk5?]:#Yj ܀j[\ImVH&i: m~:@m+-{Axt7h_MM3A 2e`n !6Q'~ l~SRRt"0Qm[Q= !K5}G]m~:c0kPmm1M@M¸j~:lXLmY;x$!݁9(_~~>8Wgն8|rrr>Ӷoq/%r0pTBm~:cͶ8i$͛muTv`O!#\΢=Om~::*a-x- =cQk m~ Vu:;wn܆%K:] uiz-4(/// hhoo:v;111-(A=uɅ WG;Zii)555-QNB-*~vvΝ;u mīttƒ 86o̡Ccĉ&ޯ5]eū384ֲ~z8@^^-~A WG'/.z5`4aDA (x^~?QQQXa퍵yIb"Wgf,Xy9[[Ɏg }vDa`XzD5s M( (HORp$n?N[\kvEU'8ve6QQQ-y̽$Lz_ aC/TUd33srfBg,hYe%p,Dn~IYrzPSuOu&I`T XVDQb_%YAz(3)639V7Jmmm|Vi G~C/VWl3q ͽ~fCY#o+f@ZġQJȊ:3FcSY~F6<@@Vdڽ-N-^=7yjrƅ#|Jƒ:9>6W\񰢤v)rJfϙinbK 7,biaI1;J7ď#0joH6!A+ ~I鑨sx9P릨ɎR';+T6y ,t:$ G NJ⪌^e)-% -Ddx|G9[[9~R2,kA{6OժLQ/`'eQ(h†aZ1V `58uZI[Χ@ -^ۑ$ ^xߩjRf9![YI|{KZԽV`îE+xg>Q!aؗᆓQ/ஈ";ktbH6h%3UΊ6<>/85&Ip\sr8й毇e7C6/+K&p`Lo}!}[cJй1=7sON( $W᧱OC{I/KDzk~( MNe}ee:,I9B瀬2i),?# }fZV` (YL8-Z[fvGcNpM:ނs 1K-)x}2mnV?u(>ƮCt Jtt^KfGGz]]M=GF/"1#tt} ]Mۛj$t:e_?mܒ111BKJp2țI:*=.X:H&]ce[M9! cIRqMj7^OkgxvIkVkK V08WN]0.J Jxy\W輾՟Vc䞫sgb0|^+ 0aaL=,](/tE1ɾHB ӳX`8=TEQ^KO} %%npQR⦺֋{ɲBn]CrrG|Ç2wM>Vl=L?hZйE ]~nx8!x}.{( ݆-ע(sg˗ 1"m&HR S}B]pA+ x2~s-[ZٶAYCޠ)h4CRR4=We*+&$qޡ_yd{;j,ԱrC9[r8n8ciEߨm-̛0n[x-@#)AjU91gIE!'{I?D[p"ԝ/b IN63n/N 8pO?mo47imu`2|Lٸ;7>Bkky( Kb{xiW51f~.)Cw6̧\2R-B϶5+6p=o3|Gzݟf?[C I4GEE h 8{3 /]>3!>HFq,̜Mqq$&2+:[(M9.|h[Kh܉<5W\:yx+to}xc6;njsFK :-KR(cv}Ԉt QT᷿-C5>G{{;jkkz +Bxqf3c4( ^I⟥nodG>$e99mzםWR\Wփ87˲{%u( z/w43~ ޚ$*6lhdK 6Ň~Q (BllsÞ8 2$zimmsNػw/HDσS&M"b?h ?K%X3 ޡX^KzJx csO.ٽg/b梋.BCߌAEy:(öDp?z@ 0wr3228c袋p\TUUm6֭[Ǘ_~Iuu5/VUQpq<\V[pLZ_%ܹd|773x;/ivEjY?7ߜgXQBmR?#Z_ [neŊ3*-#wYV&OԩSYt):`cS2$'W,>Ime;Y<3kN#tyl]9ߔ8XzCK o9[8XnwRVqcgnl6 @CC_(//jJ+;`05k{/k֬ɩ(TقtNjRcYhS7Mh4jǒ.Q$IȲLnn.oy83bGx`JZ<0I39qR\йÊwJpz\4SI:4xyZ\yeg{fNJ%䒟}`0 |<(25Zv'j*n6#(Rv6qD>5J_y2vpr^<_+TT㎋㦛1ؓLQ`J>sr뭷%sJE8Okkc IHLL7 iiiuK uN>>HZ{?hSY xj95kFyFV$.=L 37j<~{_m|Qdz<eu]o[27}eN $S뽬x3z:׫s}g{a Aॗ^bڵAhvEEQDQꫯf lFNk#:$e(urʂIV/Ӂ$5l)lйSQ+f͛--[x衇[J0`4[9묳hhJ<Ι`(Aa/YEJ{%%}f akϾYI|{%=mA/ZX.rrrBuEZP]]8Vӄ[i{vf0/W\Uέm:ŋ{$uPW .R>찄~Gy/rLVo<`KE-V$1|.2ڼ2|ZIWR?*ɩ$p^s@_+cVN<1˳zβ O=U_43~^XCw}EQFew16 #&(Bp65&&в,%g??)'ISW6Uhޫ'{/x*MszCoSOU]wEVVVȽ``Ϟ=<8NGQ_" _5˗/'>0"hlCjj 'r1pI'1ydL&SXBQ-s' s 4G, TzXL q;tUC7|9guVX<{s&B8@@ӋAb5>I5cHY+^ye9쳹+7o^pP0 }<󼵭YQXr|"WM2Z7|r<7ܠ:w $ |MZ8c馛0ay}1_WX#0ndpz~^*TfCPFQoogsǥivWS*h>ok%Ib̙L0ݻwlឫsI7 ?ޮ")Iu7wx~}WWwMfffXB?Gy@ @LL̘Y2ꋱ5ijǥHm1cQ% jz@3'F9(^NI`ɒD2?)BRR3fࢳqܸ^sy pYzjBйˊ%45+XdIE*?SWW7]F'}cIU38Ύ$+긢 Ŗ$śț$$I!'MmqqF|p*4bbV\ɛor(i2>}:nc+# ؾ)''pYʦHȋTΩ^ 763sw7|_~EQ̾y_ m5`o4' %yms )n\Gv9c "Ng]|'!7씔F >|eQDQgJhw,N9%W\]--W]u/˸wΝ5q\a]JDtZ.{@sv &嘙z_8T̴`4NL4 27o& f3NW_FRJ^'%p}CKl 7WZZZ9tF Immm8#GaDdY`Ou;5zֹHI4krݖmoF͋A;mM`2^oHfɈ' )DwII1s=u{nC}E駟?BҬ]|HDTTԘ<Ĉ@qe7>}5uIح[-?aa^|eW :Zĉ6N8!.8~V5`2A{ ߏj(jXV,\;tTCV;9vZXB׳rJl6"7󝔖nm6ۘZ<Ĉ6x(m`Ͷ0/OM9DیYi Ap+-W &; $!K$(\SN^'5?t@k't_=!(Fne<7ߜ( \yL};|A_|BU7Xn(B#0cb4)L̲oR"+1:q$ _h淏`v;/+챛}|>HJJl6rMl.lwIL4q]HN:Q#?_Ebb"w}7iii! x?ۉ2PVq8(Zj&.H\%K),l ׋n;gu101eOhI-Evv^_W˚kkqLݖdow(0uԐf&|>/ &VVNz%uTTxXC旿E%a>^]b:@@,(Jd]4NYVm2z㓩vjHiR|-E-l'.gq=( yVrJc YbvfEsu(A#yrmsp'-t䡇B=X4iƍ#::Q|8Njkk)--esJKKUATTeԅԺA6b dZHM53yr˂10ts >Z /TNllEvǏ{ / 'xÆ Ų,I{Dٹjsm޷>^ʮ]??Ez'm|e HNN_~y&I1c=˗/,yF[K+nA^ EQ`T:ksU.l2N?233qx<ᾬ x c0_˥aaɒn(׭lDvv6˖-/$Ib…u]XV\.WH^@DDQ㮻5b0myN .I&ժVhyˁ@ǃ% Fև(,[H|E x/˾A]75hQ2vj㣏IJJ'? !lpaDqq1߿IKKc,Xӧr-|TUU"&[KAJYY>(/"pL.u1bz%^uu>.tfΜ6 jjjXv-o;wv=s1\r%s9A!$I̞=K.nL&SD trдBR)\4݇)m%'$0?jc׿m6YfFf'ɜhA,6\;Oul)ja||{r2cƌkYlk֬@ h(駟/i&|>$ks99/Ap+ u>ݪQ~Ҥwqa$I 466p¤8n6 V/+חhA&EqX.fFzO<1Xe&Mʕ+x<!`}k( lڴ￟.'|#f7r1Z[X7rɜp eK/?WK3vu`B,YIV Dـ'tLᬓ8;/bvr6`?111|X&;.M6zzMEQNc!BE>3(@%=&$Yݥk;CPQRS!3s|Qu[`\,˦qgH2Fz%(`Ahn'>H\u3iTrI}w.W_W^yK2}A_(̟?H @Q= xzO=Swߠ,ˤsmqM7rC9Hdnv4fx=/yPQᥭM&++A oRll؉q\rR:]w.ZcD+Ecx2$)~z"gڵꊃAQ&MDll,---#^z=h0j7LbFZ]3s7&ddYs?M^ _@!#APQ锋z?Ƌ,CFFFH (r HZ3M$#B/$E}-H‚ح]"AWLV-l6 .H`7t:Cz&''6D# X헍dhhq,]::~o V[n!+;モ&8X fZ!cws@}PZ񰸸<#6&snDAGED ,>.1XI$>f?dϏ!-̾} ׌"111x/G2AgG]Y8/'kr5ywٴiSH]tݵŀl`a@&.Wgo(p qqq!OSQ`]q#?$&feL,j|4zIJ6bfZ}"bP.`^+k̟ 8\t&MqF>BWEQHNNo'::w mwLX>55ABQ1a鱩Ɏd$w]v?? % piSHJ2EM} 艫bdE!;qv6ns#7.">ȿ]k<v{eYE:,JIp|^x!,;O,\K.$0Pχ_6pғ-l툢@v2ZZZݘEaܸqydXZ iVAEAhp{d>^ %̊SXt]7ިh4q9&AӉ`{pa41^%8( `0FQ@ OcRmx8Na֭kd,⌬YS,A^wu|a+ϔ gDS7߬#PȰi``ٲe'uo{TxoSP/wk\".M~1< ~^RMA=buyږ6jݏ?+x偹hI*sjٲEMꪫBq[oo`ZzȲL #eY0o=-27 .୷bO8x5ݿ`"))ŋgp9py瑝 f?<>|1jmhAO 0R/F#6 C#tocZ]_6u\|q7ܐma՜uY!U%2{.YfMj}{{;@a8# s=iӦ,seΜ9|͔QVV,""1113~x233p5DQdڵlٲFVVqtuncقVsq>DϟiYYEʕ+W;rth )(AC3Vłb`ީәeپM7)/˄֜9skEvANFjk}46믿믿4CMV#9zwwq#cJc /??veHH͆ <*$Y] b9$JJJ’bݛK/N8!hJ\\\rb nK-G< k׮`05s{2ܕUn^_+U5y߮筷䓦n%' t$-OWRXvZ[[yꩧO 2SN rz `T`2شi_=֭ \.=wuWP#zKG68ՖYHcc3%%nnyZBY~=?C^fQe˖~znłh]v|rnJº3X}kǼv= zD[1-f %#ªxk5LnVZESSSȍR۽n#!!ۄVO 111vӟu]g},V hg}.5k I9#u#F1sbWMMM@hLn*Ilٲ~;KPCSN9K/{oР3L&[m۶qp3g, $ҵ---lܸ{M6X,;mor$A' Qi͆d՜x$''%ҥ{:tm='ZHviiiw3?1{, *"^6nțo7|h4xM>I]vYH!vjxعs'?O:*q\֌- ^}Uz-f̘駟΢E>}:IIIfA(EU]E V{\.***ؾ};6l`TTT( FhVkDG]@{ٳ'sYZmlt:))) EQDQԲ%QQQlA[ھ};۷ogʕ0sLfϞ͔)S"11(f3F13*pPWWGii)w令}Q[[8f3V ɫmjMׇ6s,&Ա(־3"cգ~tt"]::.`FN XG'щ`(I:::CJXt΂ HHHЅ3h:KHH`#Xy摓CQQ{ ^*SNeܹH|g*48S4it!ͻ<~xHOOZ)~Bkxff&:tjkkFθqcĉL W@54L6,vΝ;q8ut(2k,fΜITT`晪 /dwf2225Z[[[ZG;PŒ3XhSLLfyŋ[$`Mv;Ǐgܸqx<N',B邢( rrrXhs 9>TX T;X 8>''qqA hhh:cM)))̝;ɓ'cX.^sk{}u,W@>EN'ڵ6]:cEQf̙̚5RT;^jBxrn~ z 8x >OΘ@Qf3&Mb޼y51#v&\oUT I(++#??J}|3jQQ``0*)Ocqo/jQI=b`@H<[HGhbb"seԩlT(^Ei]!\z* W;w{n\..bF L>9s`[, 8^~}.Bہ߽UƎ@mm-u!D`20ayyy f <+Ñ{ܞ J5]l2cA>||jjjΈG[JOO'// &+H <a`Zze] rػw/EEE43gMVoa?jK@vp0CSQE|wbmnnm:#Yl~0qn2xBǹG"l "dj8}'=0Q2Z- ;y'''<222muYK@= 29 uv ~ ~:D~~>uuuzZΐT͛ĉc8PPSB p5"?v[KP8A]- f QC( ~GU =dzP@.FM vߏՅV4ߔ)S;w.x xة wە!QA!Q1DM4B;2+++ٱcH Y'$4_VVyyydee &ч' +\!m]j~,x^8@aan[@7o^7G5PWc[}:Nbր.\- 0P1l-n" uf8q"yyy%vC-\ao=lgOc;vPUUej#''g03:m~^>j?L~ m(vuۢV.:m~M,p0Zv!7WuHl~6']m|>aPm~1HP1[s!-Dj}iN҂6?Pǹ!ߊ{Vi[2/G%]m~gf^$ 6"bZośKm}rEy$"26iӦ1gsQm~a/\Fɨam;v젬L-Fa=|Am~CEĶ Pm ; V[m#0'\n=t:mt:lvX-@E!&&ٳg3cƌ,6?\B Xgi[lCCmq&O̼yBUHFp5FU"d3mGm~P626bԵ\żmQ9zW@ͯU;c8km#7c f͚Ell`[IͯL;8zݮc|նA9tn[ #]m~#55u6t3--tOE-a=| c-yjU9o7t`Ƙ5z'i[st-gݶfϞM|||^@%j֦Ȃ t-{ݶ?h{5\ z+[m ~4bIIIڢvCDoۭ }/3H={عs瘵-jcΜ9iU[4Tm[űb[TT.zOA eŪ*Gm16Q#7TΖF9N wIII!///6TߛDo-(ӣb:s:a[lkkcݣƶj~iHضu٭gzgmq-p-%%% fY,Ej5#p+**Ϗۢfd7*m~Cn-#.BӶ8o bWܹs2eJ(6GQ{Vb^{j%He:m9 8ٽ{-*BTTT_6gQǺ7T2 QMB-A(((vbm~o.oGmօ&tųQ׏l[ ?0>G9P (.ۢVmQ&qm@UD/ tEzym a[liiaΝGͶ*!^D]6BE"pj6׈-j鏚/===ftߐ xa[zt=-&]mZ#j~auJ 3>lwFۢ233c]Í.BPAm[ϧ^S¼y4iR(6FG= :mrE j~AHt@zyI"a[x[Ay-.F/a⧳t߈Gpb?(Dq6?]#]BԱm>΍$tG]I,@M-vFo/"a[Xw%:m~"]LKPm3-{5juF.Gb[H8VD>E-w| o-l=dR=%tEXtdate:create2019-12-12T18:49:28-06:00Q%tEXtdate:modify2019-12-12T18:49:20-06:00MtEXtSoftwarewww.inkscape.org<IENDB`R6/man/figures/logo.svg0000644000176200001440000002723513745631032014456 0ustar liggesusers image/svg+xml R6/man/is.R6.Rd0000644000176200001440000000132613104125424012502 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/is.R \name{is.R6} \alias{is.R6} \alias{is.R6Class} \title{Is an object an R6 Class Generator or Object?} \usage{ is.R6(x) is.R6Class(x) } \arguments{ \item{x}{An object.} } \value{ 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.} } } \description{ Checks for R6 class generators and R6 objects. } \examples{ class_generator <- R6Class() object <- class_generator$new() is.R6Class(class_generator) is.R6(class_generator) is.R6Class(object) is.R6(object) } R6/DESCRIPTION0000644000176200001440000000172214107461745012262 0ustar liggesusersPackage: R6 Title: Encapsulated Classes with Reference Semantics Version: 2.5.1 Authors@R: person("Winston", "Chang", role = c("aut", "cre"), email = "winston@stdout.org") Description: 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. Depends: R (>= 3.0) Suggests: testthat, pryr License: MIT + file LICENSE URL: https://r6.r-lib.org, https://github.com/r-lib/R6/ BugReports: https://github.com/r-lib/R6/issues RoxygenNote: 7.1.1 NeedsCompilation: no Packaged: 2021-08-06 20:18:46 UTC; winston Author: Winston Chang [aut, cre] Maintainer: Winston Chang Repository: CRAN Date/Publication: 2021-08-19 14:00:05 UTC R6/tests/0000755000176200001440000000000013104125424011677 5ustar liggesusersR6/tests/testthat/0000755000176200001440000000000014107461745013554 5ustar liggesusersR6/tests/testthat/test-nonportable-inheritance.R0000644000176200001440000001551313104125424021456 0ustar liggesuserscontext("nonportable-inheritance") 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-nonportable.R0000644000176200001440000001226113745631032017174 0ustar liggesuserscontext("nonportable") 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-portable.R0000644000176200001440000001153613104125424016455 0ustar liggesuserscontext("portable") 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-set.R0000644000176200001440000000571213355423661015453 0ustar liggesuserscontext("set") 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.R0000644000176200001440000000235313745631032016640 0ustar liggesuserscontext("S3 methods") 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.R0000644000176200001440000000031113104125424015134 0ustar liggesusersexpect_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-finalizer.R0000644000176200001440000001746513745631032016647 0ustar liggesuserscontext("finalizer") test_that("Finalizers are called, portable", { parenv <- new.env() parenv$peekaboo <- FALSE AC <- R6Class("AC", public = 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", public = 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( finalize = function() { pub <<- self$mypub; priv <<- private$mypriv }, mypub = TRUE ), private = list( 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( finalize = function() { pub <<- self$mypub; priv <<- private$mypriv }, mypub = TRUE ), private = list( 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( finalize = function() { pub <<- mypub; priv <<- mypriv }, mypub = TRUE ), private = list( 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", public = 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", public = list( finalize = function() cat("An AC was just deleted") ) ) BC <- R6Class( "BC", inherit = AC, public = 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", public = list( finalize = function() cat("An AC was just deleted\n") ) ) BC <- R6Class( "BC", inherit = AC, public = 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", public = list( finalize = function() cat("An AC was just deleted\n") ) ) BC <- R6Class( "BC", inherit = AC, public = list( finalize = function() { super$finalize() cat("A BC was just deleted\n") } ) ) CC <- R6Class( "CC", inherit = BC, public = 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", public = 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", public = list( finalize = function() cat("An AC was just deleted") ), portable = FALSE ) BC <- R6Class( "BC", inherit = AC, public = 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", public = list( finalize = function() cat("An AC was just deleted\n") ), portable = FALSE ) BC <- R6Class( "BC", inherit = AC, public = 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", public = list( finalize = function() cat("An AC was just deleted\n") ) ) BC <- R6Class( "BC", inherit = AC, public = list( finalize = function() { super$finalize() cat("A BC was just deleted\n") } ) ) CC <- R6Class( "CC", inherit = BC, public = 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", public = list( finalize = function() cat("An AC was just deleted\n") ), portable = FALSE ) BC <- R6Class( "BC", inherit = AC, public = list( finalize = function() { super$finalize() cat("A BC was just deleted\n") } ), portable = FALSE ) CC <- R6Class( "CC", inherit = BC, public = 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 }, 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("Private finalizers work", { sum <- 0 C1 <- R6Class("C1", public = list( x = 1 ), private = list( finalize = function() sum <<- sum + self$x ) ) a <- C1$new() rm(a) gc() expect_identical(sum, 1) }) R6/tests/testthat/test-clone.R0000644000176200001440000010100713746334241015751 0ustar liggesuserscontext("clone") 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("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-portable-inheritance.R0000644000176200001440000002506614103314331020744 0ustar liggesuserscontext("portable-inheritance") 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("pryr", quietly = TRUE)) { expect_true(pryr::object_size(BC) < pryr::object_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/manual/0000755000176200001440000000000013104125424013154 5ustar liggesusersR6/tests/manual/README0000644000176200001440000000021213104125424014027 0ustar liggesusersThe 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/test-inheritance.R0000644000176200001440000001416213104125424016551 0ustar liggesuserslibrary(testthat) context("Inheritance across packages") ## 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/manual/encapsulation.R0000644000176200001440000001076613104125424016156 0ustar liggesuserslibrary(pryr) 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/testthat.R0000644000176200001440000000006013104125424013656 0ustar liggesuserslibrary(testthat) library(R6) test_check("R6") R6/R/0000755000176200001440000000000014103314331010733 5ustar liggesusersR6/R/env_utils.R0000644000176200001440000000250113104125424013067 0ustar liggesusersencapsulate({ # 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/print.R0000644000176200001440000001035413745631031012227 0ustar liggesusers#' @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/utils.R0000644000176200001440000000233113104125424012220 0ustar liggesusersencapsulate({ # 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/aslist.R0000644000176200001440000000047613104125424012367 0ustar liggesusers#' 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/is.R0000644000176200001440000000132613104125424011476 0ustar liggesusers#' 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/generator_funs.R0000644000176200001440000000607313355423661014124 0ustar liggesusers# 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/clone.R0000644000176200001440000002665113746334241012206 0ustar liggesusers# 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. if (is.environment(value) && !is.null(value$`.__enclos_env__`)) { 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/aaa.R0000644000176200001440000000236613104125424011612 0ustar liggesusers# 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/r6_class.R0000644000176200001440000004272314103314331012602 0ustar liggesusers#' 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. #' @param lock Deprecated as of version 2.1; use \code{lock_class} instead. #' @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(), lock) { 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.") if (!missing(lock)) { message(paste0( "R6Class ", classname, ": 'lock' argument has been renamed to 'lock_objects' as of version 2.1.", "This code will continue to work, but the 'lock' option will be removed in a later version of R6" )) lock_objects <- lock } # 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" generator }) R6/R/new.R0000644000176200001440000002473613745631031011675 0ustar liggesusers# 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, cloneable = cloneable) } else { # Set up the superclass objects super_struct <- create_super_env(inherit, public_bind_env, portable = FALSE, cloneable = cloneable) } 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 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, cloneable = 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, cloneable) 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/NEWS.md0000644000176200001440000001334214103314434011637 0ustar liggesusersR6 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 instantation, 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/MD50000644000176200001440000000334314107461745011065 0ustar liggesusers1822b1884ade0c37ce3184713c8e8a6a *DESCRIPTION 2491c4039e00be047cce99c452d3fd00 *LICENSE 2290c691ec0011ac745e45d5874fa193 *NAMESPACE 57bef973aa14163a545adc21ed2707fc *NEWS.md 890797fed39cbc35799c315d9c322108 *R/aaa.R 8fc2b68dd2ba714c478255c42d60fdb5 *R/aslist.R facbdd1ef5ec209c49ff8d72863971c5 *R/clone.R 969da6f631df9a1f7fbdf9531f60b4dc *R/env_utils.R bdc3eed04493e6eda7707b085e127963 *R/generator_funs.R da8d32330b60debc59dc9ce8a31e877c *R/is.R 27c3582306223bf21c70f249b68398eb *R/new.R 31f32ed63aacaf439848ef43dde09add *R/print.R 143bc629827ea97ed55602c49ea9263a *R/r6_class.R b88a321a00815f8fbf23a3eac1790f5d *R/utils.R c8050b317ee728b6a42dd3643db7109e *README.md d3db5f5dfeb806cd13424eba95b23b0a *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 a6eb9df5a1cef6cf0b94c958ec25a7a3 *tests/manual/encapsulation.R cbaba26cf0c3e5a9004f9a03123028fa *tests/manual/test-inheritance.R 08d4cdb1a57dc1e4307c6f4c8d83e65e *tests/testthat.R 45a99007ec8c0255886a2100904c2cae *tests/testthat/helper.R 9fb5a9f9d2a0be1d6a78b04596de3dc8 *tests/testthat/test-clone.R fbdae85d4a8f44fac2227898b2f657b5 *tests/testthat/test-finalizer.R 890765388a44c68277dcb82c4dbb2141 *tests/testthat/test-nonportable-inheritance.R ad3a10994e14247f138f5fa7b0c14bb9 *tests/testthat/test-nonportable.R b14ef8fabb29c8e253c5faa8613b069a *tests/testthat/test-portable-inheritance.R 44f73a7b77858cc4dc7e2f9f13ad041f *tests/testthat/test-portable.R d965b9c92c8417097ea262d09d704090 *tests/testthat/test-s3-methods.R f2a83c3eb893dde5fb896a58eca12b28 *tests/testthat/test-set.R