I decided to give Reference Classes another shot, but my first hello world is already giving me issues. What is going wrong here?
> memory <- setRefClass(
+ Class = "memory",
+ fields = list(state="vector"),
+ methods = list(
+ get = function() { return(state) },
+ set = function(x) { state <<- x }
+ )
+ )$new()
> memory$set(123)
> print(memory)
Reference class object of class "memory"
Field "state":
[1] 123
> memory$get()
[1] 123
> print(memory)
Reference class object of class "memory"
Field "state":
Error in methods::show(field(fi)) :
error in evaluating the argument 'object' in selecting a method for function 'show': Error in get(name, envir = .self) :
unused argument(s) (name, envir = .self)
I'm not very experienced with Reference Classes but according to the help page (?ReferenceClasses), I think that you have to add a show method to your class to be able to print automaticaly your object.
memory <- setRefClass(
Class = "memory",
fields = list(state="vector"),
methods = list(
get = function() { return(state) },
set = function(x) { state <<- x },
show = function() {methods::show(state)}
)
)$new()
memory$set(123)
print(memory)
#[1] 123
memory$get()
#[1] 123
print(memory)
#[1] 123
Hope this help
Related
While playing with reference classes in R i ran into something that does not feel pretty. If I have a list of objects is there a way to remove an individual item from that list that does not involve finding its index? In the (working) example below I would like a better way to implement removeContent() i.e. some way to remove the item from the list without having to loop. I am trying to stick to base R if at all possible.
Element <- setRefClass(
Class ="Element",
fields = list(
m_name = "character",
contentList = "list"
),
methods = list(
initialize = function(name = NULL) {
"Element constructor, #param name, The name of the tag (optional)"
if(!is.null(name)) {
m_name <<- name
}
},
addContent = function(content) {
"Appends the child to the end of the content list. return the parent (the calling object)"
idx <- length(contentList) + 1
contentList[[idx]] <<- content
return(.self)
},
findContentIndex = function(content) {
"Find the position of the content in the contentList or -1 if not found"
for (idx in seq_along(contentList)) {
if(identical(content, contentList[[idx]])) {
return(idx)
}
}
-1
},
removeContent = function(content) {
"Remove the specified content from this element"
index <- findContentIndex(content)
if ( index != -1){
contentList <<- contentList[- index]
} else {
stop("There is no such content belonging to this Element")
}
}
)
)
foo <- Element$new("foo")
foo$addContent(Element$new("Bar"))
baz <- Element$new("Baz")
foo$addContent(baz)
foo$removeContent(baz)
tryCatch(
{
foo$removeContent(baz)
},
error=function(cond) {
print(paste("Expected this error, ", cond$message))
}
)
The way to do it without using explicit indexing would be to use sapply(contentList, identical, content) to find a matching object. We can simplify your whole class definition, preserving functionality, like this:
Element <- setRefClass(
Class = "Element",
fields = list(m_name = "character", contentList = "list"),
methods = list(initialize = function(name = NULL)
{
if (!is.null(name)) m_name <<- name
},
addContent = function(content)
{
contentList <<- append(contentList, content)
},
removeContent = function(content)
{
idx <- sapply(contentList, identical, content)
if (all(!idx)) stop("Content not found")
contentList <<- contentList[!idx]
})
)
Now we can test it out on your examples:
foo <- Element$new("foo")
foo$addContent(Element$new("Bar"))
baz <- Element$new("Baz")
foo$addContent(baz)
foo
#> Reference class object of class "Element"
#> Field "m_name":
#> [1] "foo"
#> Field "contentList":
#> [[1]]
#> Reference class object of class "Element"
#> Field "m_name":
#> [1] "Bar"
#> Field "contentList":
#> list()
#>
#> [[2]]
#> Reference class object of class "Element"
#> Field "m_name":
#> [1] "Baz"
#> Field "contentList":
#> list()
foo$removeContent(baz)
foo
#> Reference class object of class "Element"
#> Field "m_name":
#> [1] "foo"
#> Field "contentList":
#> [[1]]
#> Reference class object of class "Element"
#> Field "m_name":
#> [1] "Bar"
#> Field "contentList":
#> list()
and with your tryCatch:
tryCatch(
{
foo$removeContent(baz)
},
error=function(cond) {
print(paste("Expected this error, ", cond$message))
}
)
#> [1] "Expected this error, Content not found"
Created on 2020-04-08 by the reprex package (v0.3.0)
Suppose I have an S4 class Test that has a single slot name. A valid name must be at least one character long, so Test(name = "Bob") should work but Test(name = "") should throw an error. An undefined name should also give an error: Test().
My class is defined as:
Test <- setClass(
"Test",
slots = c(name = "character"),
validity = function(object) {
if (nchar(object#name) == 0) {
return("name must at least one character long")
}
T
})
Testing the class in the console, I find that my validity function is not executed for the unassigned case:
> Test(name = "Bob")
An object of class "Test"
Slot "name":
[1] "Bob"
> Test(name = "")
Error in validObject(.Object) :
invalid class “Test” object: name must at least one character long
> Test()
An object of class "Test"
Slot "name":
character(0)
How can I ensure that an error is always thrown when an invalid object is created?
One way to ensure the validity of an S4 is the use of prototype to initialise the slots like this
Test <- setClass(
"Test",
slots = c(name = "character"),
prototype = prototype(name = 'name_default'),
validity = function(object) {
if (nchar(object#name) == 0) {
return("name must at least one character long")
}
})
Test(name = "Bob")
## An object of class "Test"
## Slot "name":
## [1] "Bob"
Test(name = '')
## Error in validObject(.Object) :
## invalid class "Test" object: name must at least one character long
Test()
## An object of class "Test"
## Slot "name":
## [1] "name_default"
another way would be to create a constructor to test the presence of name:
consTest <- function(name) {
if (missing(name)) {
stop("name is missing")
} else {
new(Class = "Test", name = name)
}
}
consTest(name = "Bob") # similar to Test(...)
consTest(name = '') # similar to Test(...)
consTest()
## Error in consTest() (from Retest.R#13#3) : name is missing
I have come across some behaviour from R reference classes I would like to work around. In the following code, reference class B has two fields of reference class A in it.
These fields in B appear to be instantiated (possibly twice) with a zero-argument (default) versions of reference class A before B's initialize() method is called. These instances are then replaced with the correct versions of instance A during B's initialization process. The problem is that if I use lock() from B's instance generator, the initial empty instantiation's of A cannot be replaced in B. Another problem is that reference class A needs a default value in initialize [or a missing(c) test].
Help - suggestions - etc. appreciated.
A <- setRefClass('A',
fields = list(
count = 'numeric'
),
methods = list(
initialize = function (c=0) {
cat('DEBUG: A$initialize(c); where c='); cat(c); cat('\n')
count <<- c
}
)
)
instance.of.A <- A$new(10)
str(instance.of.A)
B <- setRefClass('B',
field = list(
a = 'A',
b = 'A'
),
methods = list(
initialize = function(c) {
a <<- instance.of.A
b <<- getRefClass('A')$new(c)
}
)
)
instance.of.b <- B$new(100)
str(instance.of.b)
Here are two possible solutions:
Don't set fields attribute:
B <- setRefClass('B',
methods = list(
initialize = function(c) {
.self$a = instance.of.A
.self$b =getRefClass('A')$new(c)
}
)
)
Set fields, but use the ANY class:
B <- setRefClass('B',
field = (a="ANY", b="ANY"),
methods = list(
initialize = function(c) {
a <<- instance.of.A
b <<- getRefClass('A')$new(c)
}
)
)
The downside of both these solutions is the type isn't enforced in a and b, i.e.
B$a = "Fred"
is now possible.
Drawing on the above, the solution I am using is (a little long because of the type checking):
A <- setRefClass('A',
fields = list(
count = function(x) {
if (!missing(x)) {
if(class(x) != 'numeric')
stop('Class A: count set by non-number')
.self$count.private <- x
}
.self$count.private
}
),
methods = list(
initialize = function (c=0) {
cat('DEBUG: A$initialize(c); where c='); cat(c); cat('\n')
count <<- c
}
)
)
instance.of.A <- A$new(10)
str(instance.of.A)
B <- setRefClass('B',
field = list(
a = function(x) {
if (!missing(x)) {
if(!inherits(x, 'envRefClass') || class(x)[1] != 'A')
stop('Class B: expecting instance of class A')
.self$a.private <- x
}
.self$a.private
},
b = function(x) {
if (!missing(x)) {
if(!inherits(x, 'envRefClass') || class(x)[1] != 'A')
stop('Class B: expecting instance of class A')
.self$b.private <- x
}
.self$b.private
}
),
methods = list(
initialize = function(c) {
a <<- instance.of.A
b <<- getRefClass('A')$new(c)
}
)
)
instance.of.b <- B$new(100)
str(instance.of.b)
I need to write one method that simultaneously updates an object and returns a value. I want to know if there is a way to do this in S4 classes. The context for this is that I am trying to write an S4 class to generate a list each element of which can be accessed only if a private key is known. To do this I need a method getNewSlot that simultaneously updates the length of the list and the key list and returns the index key pair. The code is provided below:
setClass("ProtectedRObjectList",
representation(objectList = "list", keys = "character", length = "numeric"))
setGeneric(
name = "getNewSlot",
def = function(object,value){standardGeneric("getNewSlot")})
setMethod(
f = "getNewSlot",
signature = "ProtectedRObjectList",
definition = function(object){
if(length(object#length)==0)
{
#initial case
object#length <- 0;
}
#update list length and generate random key
object#length<-object#length + 1;
object#keys[object#length]<-paste(sample(c(letters, LETTERS), 15, replace =TRUE), collapse = "");
#return "index, key" pair
return(list("index" = object#length, "key" = object#keys[object#length]))
}
)
Here is the output of this method. As you can see, the code returns the desired "index, key" pair, but doesn't update the object.
> thisObj<-new("ProtectedRObjectList")
> thisObj
An object of class "ProtectedRObjectList"
Slot "objectList":
list()
Slot "keys":
character(0)
Slot "length":
numeric(0)
> output<-getNewSlot(thisObj)
> output
$index
[1] 1
$key
[1] "cjdkDvAaNjvVKdw"
> thisObj
An object of class "ProtectedRObjectList"
Slot "objectList":
list()
Slot "keys":
character(0)
Slot "length":
numeric(0)
maybe this is not what you want, but probably R5 class is suitable for your purpose since you need pass-by-reference function call.
it is easy to rewrite R5 class from S4 class (and implementation in R5 is easier than that in S4).
Here is a definition (note that field length is replaced by len because of name duplication):
ProtectedRObjectList <- setRefClass(
"ProtectedRObjectList",
fields = list(objectList = "list", keys = "character", len = "numeric"),
methods=list(
getNewSlot = function(){
if(length(len)==0)
{
#initial case
len <<- 0;
}
#update list length and generate random key
len<<-len + 1;
keys[len]<<-paste(sample(c(letters, LETTERS), 15, replace =TRUE), collapse = "");
#return "index, key" pair
return(list("index" = len, "key" = keys[len]))
}
)
)
and usage:
> thisObj<-ProtectedRObjectList$new()
> thisObj
An object of class "ProtectedRObjectList"
<environment: 0x116207c30>
> thisObj$len
numeric(0)
> thisObj$keys
character(0)
>
> output<-thisObj$getNewSlot()
> output
$index
[1] 1
$key
[1] "GeCyCTdIflcYFbE"
>
> thisObj$len
[1] 1
> thisObj$keys
[1] "GeCyCTdIflcYFbE"
If you find a bug in a package, it's usually possible to patch the problem with fixInNamespace, e.g. fixInNamespace("mean.default", "base").
For S4 methods, I'm not sure how to do it though. The method I'm looking at is in the gWidgetstcltk package. You can see the source code with
getMethod(".svalue", c("gTabletcltk", "guiWidgetsToolkittcltk"))
I can't find the methods with fixInNamespace.
fixInNamespace(".svalue", "gWidgetstcltk")
Error in get(subx, envir = ns, inherits = FALSE) :
object '.svalue' not found
I thought setMethod might do the trick, but
setMethod(".svalue", c("gTabletcltk", "guiWidgetsToolkittcltk"),
definition = function (obj, toolkit, index = NULL, drop = NULL, ...)
{
widget = getWidget(obj)
sel <- unlist(strsplit(tclvalue(tcl(widget, "selection")),
" "))
if (length(sel) == 0) {
return(NA)
}
theChildren <- .allChildren(widget)
indices <- sapply(sel, function(i) match(i, theChildren))
inds <- which(visible(obj))[indices]
if (!is.null(index) && index == TRUE) {
return(inds)
}
if (missing(drop) || is.null(drop))
drop = TRUE
chosencol <- tag(obj, "chosencol")
if (drop)
return(obj[inds, chosencol, drop = drop])
else return(obj[inds, ])
},
where = "package:gWidgetstcltk"
)
Error in setMethod(".svalue", c("gTabletcltk", "guiWidgetsToolkittcltk"), :
the environment "gWidgetstcltk" is locked; cannot assign methods for function ".svalue"
Any ideas?
How about the old-school way of getting the source, applying the change and rebuilding?
you can first get the generic out, and then fix the generic by setMethod in your global environment, and then assign it back to that namespace
.svalue <- gWidgetstcltk:::.svalue
setMethod(".svalue", c("gTabletcltk", "guiWidgetsToolkittcltk"),
definition = function (obj, toolkit, index = NULL, drop = NULL, ...)
{
widget = getWidget(obj)
sel <- unlist(strsplit(tclvalue(tcl(widget, "selection")),
" "))
if (length(sel) == 0) {
return(NA)
}
theChildren <- .allChildren(widget)
indices <- sapply(sel, function(i) match(i, theChildren))
inds <- which(visible(obj))[indices]
if (!is.null(index) && index == TRUE) {
return(inds)
}
if (missing(drop) || is.null(drop))
drop = TRUE
chosencol <- tag(obj, "chosencol")
if (drop)
return(obj[inds, chosencol, drop = drop])
else return(obj[inds, ])
}#,
#where = "package:gWidgetstcltk"
)
assignInNamespace(".svalue", .svalue, ns = "gWidgetstcltk")