Implementing basic arithmetic in S4 class object - r

I'm creating a S4 object of the money class in the following manner:
# Create class ------------------------------------------------------------
# Create S4 class object holding money and export to generator function
setClass(Class = "money",
slots = list(currency = "character",
value = "numeric")) -> money
For which I'm later defining the show method:
# Methods -----------------------------------------------------------------
# Create show method
setMethod("show",
"money",
function(object) {
cat(switch(object#currency,
GBP = intToUtf8(163)),
format(
x = round(object#value, 2),
trim = TRUE,
big.mark = ",",
big.interval = 3
),
sep = "")
})
Preview
So far it works as promised:
# Create test object
tst_fig <- new(Class = "money",
value = 1e6,
currency = "GBP")
# Show the object
tst_fig
# £1,000,000
Problem
I would like to enable basic arithmetic on that object:
>> tst_fig + 1e6
Error in tst_fig + 1000000 : non-numeric argument to binary operator
Desired results
> tst_fig + 1e6
# £2,000,000
Attempts
Naturally this is won't work:
>> setMethod("+",
... "money",
... function(object, x) {
... object#value + x
... })
Error in conformMethod(signature, mnames, fnames, f, fdef, definition) :
in method for ‘+’ with signature ‘e1="money"’: formal arguments (e1 = "money", e2 = "money") omitted in the method definition cannot be in the signature
Side notes
There is a similar excellent answer provided by #Roland on implementing money class in S3; in the context of this question I'm interested in creating S4 class that would behave in a similar manner without any specific reason other than curiosity. The key requirements is that isS4() on that object returns TRUE.
What I mean by similar manner:
It prints like nicely formatted money but permits all operations the one could do on a common numeric.

I came across how to do this in my own question here. I have generally used the setMethod('Arith') approach as it is more concise when you intend to implement several operations. If you search the documentation ?Arith you will see that it list the different operations as well as other S4 group generics.
As the error suggests you need to have e1 and e2 defined for Arith methods. In your specific case the following works.
Note - to get your desired output (i.e. a money class object) you will need to create a new money object.
setMethod("+",
c(e1="money", e2="numeric"),
function(e1, e2){
new(Class = "money", value = e1#value + e2, currency = e1#currency)
}
)
tst_fig + 1e6
[1] £2e+06
However, as I said, you probably want the more general, concise version which uses .Generic to interpret the Arith method you are using.
setMethod("Arith",
c(e1="money", e2="numeric"),
function(e1, e2)
{
op = .Generic[[1]]
switch(op,
`+` = return(new(Class = "money", value = e1#value + e2, currency = e1#currency))
)
}
)

Related

Validity check of inherited and internal members within a S4 class

I extend the basic R-type array with the following S4 class:
setClass("marray",
representation(
shape = "integer",
ndim = "integer",
size = "integer",
order = "character"
),
prototype(
... # some default values
),
contains = "array"
)
Within a class method I will set the dimension of the array:
setMethod("reshape",
signature = "marray",
definition = function(object, dim = NULL, order = c("C", "F") {
order <- match.arg(order)
if (identical(object#shape, dim) && identical(object#order, order))
return(object)
if ((identical(object#shape, dim)) && (!identical(object#order, order)))
object <- flatten(object, axis = NULL, order = object#order)
if (identical(order, "C"))
dimC(object#.Data) <- dim
else
dim(object#.Data) <- dim
if (is.null(dim)) object#.Data <- as.array(object#.Data)
object#shape <- as.integer(DIM(object#.Data))
object#ndim <- as.integer(length(object#shape))
object#size <- as.integer(prod(object#shape))
object#order <- order
object
}
)
If dim is NULL, the following error occurred: "Error in (function (cl, name, valueClass) : Assignment of an object of class integer in an object of class marray is not allowed for #.Data"
I can understand the error, but what is a proper way to get rid of it?
With this workaround within the method everything works pretty fine:
data <- object#.Data
dim(data) <- dim
object#.Data <- as.array(data)
My feeling tells me that this workaround is not necessarily the best way to get around this problem. Saving the array (.Data) in a variable (data) and afterwards restoring it back seems to me a huge memory issue.
Many thanks in advance

Overload log function

I am trying to overload some functions in the context of S4-classes. Here is a sample code:
foo <- setClass(
Class = "foo",
slots = c("name" = "character", "value" = "numeric")
)
setMethod(f = "exp",
signature = c(x = "foo"),
definition = function(x) {
exp(x#value)
}
)
setMethod(f = "round",
signature = c(x = "foo", digits = "foo"),
definition = function(x, digits) {
round(x#value, digits#value)
}
)
setMethod(f = "log",
signature = c(x = "foo", base = "foo"),
definition = function(x, base) {
log(x#value, base#value)
}
)
While the exp and round functions work just fine, the log function does not with the following error:
Error in match.call(definition, call, expand.dots, envir) :
unused argument (base = c("foo", ""))
This is confusing as the args function states that the name of the second (optional) argument is indeed base.
Would you know what the issue is? Thanks.
From the help page for log,
"Note that this means that the S4 generic for log has a signature with only one argument, x, but that base can be passed to methods (but will not be used for method selection). On the other hand, if you only set a method for the Math group generic then base argument of log will be ignored for your class."
So, you can't use "base" in your signature. If you really need dispatch on the base argument, you will have to write a second generic:
myLog <- function(x,base) log(x,base)
setGeneric(myLog,signature=c("x","base"))
On a separate issue, you don't need to write separate definitions for every function like this, you can use group generics. In your example, you could write
setMethod("Math","foo",function(x)callGeneric(x#value))
or possibly
setMethod("Math","foo",function(x,...)callGeneric(x#value,...))
And this single line of code will make all of
[1] "abs" "sign" "sqrt" "ceiling" "floor" "trunc" "cummax" "cummin"
[9] "cumprod" "cumsum" "exp" "expm1" "log" "log10" "log2" "log1p"
[17] "cos" "cosh" "sin" "sinh" "tan" "tanh" "acos" "acosh"
[25] "asin" "asinh" "atan" "atanh" "cospi" "sinpi" "tanpi" "gamma"
[33] "lgamma" "digamma" "trigamma"
work as desired (by operating on the #value slot of foo). You might also want to do something similar for math2, which includes round.
A third way to achieve what you want is to have your "foo" class extend the numeric class:
setClass("foo",
slots = c("name" = "character"),
contains="numeric"
) -> foo
Then everything works as if the objects are actually numeric. If you need to get at the "data part" of an object x of class foo, then you can use foo#.Data.

Setting an S4 slot to function and representing a neural network layer

I am attempting to write some classes in R. Here is the start of a neural network layer class. It is generating warnings and errors that I don't know how to correct.
# Slot definitions
setClass(
Class="neuralNetworkLayer",
representation=representation(
input = "vector",
linearOutput = "vector",
squashedOutput = "vector",
hasBias = "logical",
bias = "vector",
weights = "vector",
gains = "matrix",
squashFcn = "closure",
squashFcnDerivative = "closure"
)
)
# Constructors
NeuralNetworkLayer <- function(nInput,nOutput,hasBias=TRUE,squashFcn,squashFcnDerivative) {
nc = list(
input = c(rep(NA,nInput)),
linearOutput = c(rep(NA,nOutput)),
squashedOutput = c(rep(NA,nOutput)),
hasBias = hasBias,
bias = c(rep(NA,nOutput)),
weights = c(rep(NA,nOutput)),
gain = matrix(data=weights, nrow = nInput, ncol = nOutput),
squashFcn = squashFcn, # source of warning / error
squashFcnDerivative = squashFcnDerivative,
get = function(x) nc[[x]],
set = function(x, value) nc[[x]] <<- value,
props = list()
)
#Add a few more functions
nc$addProp = function(name, value) {
p <- nc$props
p[[name]] <- value
assign('props', p, envir=nc)
}
nc <- list2env(nc)
class(nc) <- "NeuralNetwork"
return(nc)
}
tanhDerivative <- function(x) {
d = 1 - tan(x)^2
return(d)
}
test <- NeuralNetworkLayer(nInput=4,nOutput=5,hasBias=TRUE,
squashFcn=tanh,squashFcnDerivative=tanhDerivative)
The messages generated are
Warning message:
undefined slot classes in definition of "neuralNetworkLayer": squashFcn(class "closure"),
squashFcnDerivative(class "closure")
Error in as.vector(x, mode) :
cannot coerce type 'closure' to vector of type 'any'
Both messages indicate that the base class closure can not be used for a slot. How to pass a function?
Taking the advice from the two answers, the following code can be generated. This addresses the original question of passing a function to a slot, and then using that function. For completeness, the revised neural network layer class is present.
setClass(
Class="neuralNetworkLayer",
representation=representation(
nInput = "numeric",
nOutput = "numeric",
squashFcn = "function",
derivSquashFcn = "function",
gains = "matrix",
hasBias = "logical",
bias = "matrix",
linOutput = "matrix",
squashOutput = "matrix"
)
)
getClass("neuralNetworkLayer")
getSlots("neuralNetworkLayer")
sf <- function(x){
f = tanh(x)
return(f)
}
dsf <- function(x) {
d = 1 - tan(x)^2
return(d)
}
# Create an object of class
hh = new("neuralNetworkLayer",squashFcn=sf,nInput=5,nOutput=5,hasBias=TRUE,
derivSquashFcn = dsf)
hh#squashFcn(3)
hh#derivSquashFcn(3)
The error/warning :
undefined slot classes in definition of "neuralNetworkLayer": squashFcn(class "closure")
means that slot is not defined beacuse the type "closure" is not defined.
You try To define a slot(attribute) as a generic function one idea is to use ANY ( the default for slot I think) type:
neuralNetworkLayer <-
setClass(
Class="neuralNetworkLayer",
representation=representation(
squashFcn = "ANY"
)
)
Then ,for example you instantiate your class like this :
# Constructors
hh = neuralNetworkLayer(squashFcn=function(x)print(x)) ## dummy function here
hh#squashFcn(10)
[1] 10
That's said , I think you should consider to define your functions slots as a real method(see setMethod) . Methods are to have typed (safer) objects Otheriwse there is no good reason the reason to use S4 system and easier to use S3 method.
I don't get why you are defining a neuralNetworkLayer S4 class while your constructor doesn't make any use of it. You just are creating a normal R list (no slots in the returning object of NeuralNetworkLayer). In your constructor you should call new somewhere.
Anyhow, your error doesn't have nothing to do with closure as you might think. You just didn't define the weights object that it happens to be also an R function. When you say:
weights = c(rep(NA,nOutput)),
gains = matrix(data=weights, nrow = nInput, ncol = nOutput),
you are creating an element of a list named weights, but you are not creating an object named weights. When you define the gains element, R just finds for weights its R function and tries to coerce it to put it into a matrix, giving the error. You can just define weights in your first line of NeuralNetworkLayer:
weights = c(rep(NA,nOutput))
and then, when you define nc, replace the first line I wrote above with:
weights = weights,
and your function won't give any error.
For the warning part of the definition of the S4 class, just use function instead of closure. However, as you have defined your constructor, you may well not define it at all.

Return a function's code

This would seem to be an elementary question, but I can't seem to find an answer on stackoverflow.
How can I obtain the following effect:
f <- function(x = 1){x^2}
miracle(f)
[1] "x^2"
The context is a shiny app (package by RStudio) in which I have a textInput() function to which I supply an initial value x^2. While this works:
textInput(inputId = "inFun", label = h4("Enter a function:"), value = "x^2")
this doesn't:
textInput(inputId = "inFun", label = h4("Enter a function:"), value = f)
It appears that I need something like "x^2" on the rhs of value.
Below is a representative sample of several variations I have tried:
eval(parse(text = f))
Error in as.character(x) :
cannot coerce type 'closure' to vector of type 'character'
f(x = "x")
Error in x^2 : non-numeric argument to binary operator
`f`
function(x){x^2}
f(x = `x`)
Error in f(x = x) : object 'x' not found
Is there a built-in function for this?
I'd like to answer my own question, based on Roman Luštrik's comment, to invite suggestions for improvements rather than raising my meagre tally of "points".
Roman suggested the function body(), which I had never heard of. Here is what body() does to f:
f <- function(x = 1){x^2}
> body(f)
{
x^2
}
The curly brackets were unwanted, so I searched a little further. I managed to get rid of the curly brackets with this:
> gsub(' {2,}','',deparse(body(f))[2])
[1] "x^2"
The above, therefore, answers my own question. But is there a more elegant and shorter way?
Following Roman's suggestion to use body(), I came across this outstanding answer by joran, hadley, and several others, which provided me with a template:
How to create an R function programmatically?
There it explains how to create a function programmatically from an argument list, a body and an environment. I therefore decided to construct my function f with these 3 primitives and to call the body from inside shiny's textInput.
So I put this in my global.R file (the small-cap g is shorthand for global)
# Convenience function
make.function <- function(args = alist(a = 1, b = 2), body = quote(a + b),
env = parent.frame()) {
subs <- list(args = as.pairlist(args), body = body)
eval(substitute(`function`(args, body), subs), env)
}
gArg <- alist(a = 1, b = 2)
gBody <- quote(a + b)
gFun <- make.function(gArg, gBody)
Then in my server.R file, I have:
textInput(inputId = "inFun", label = h4("1. Enter a function:"),
value = deparse(body(gFun)))
And it works!
I was planning to write value = gBody or something to that effect, but my first success came with deparse(body(gFun)), so that's what I'm using now.
The use of make.function to produce a 'static' function in global.R is of course overkill, but I'm using make.function elsewhere inside server.R to process the user-supplied arguments and body to create new functions and plot them, so it's a very useful function to have.
Thanks Roman: if you write your own answer I'll accept yours.

Make S4 object act as an S3 class?

I would like to write an S4 object such that it can be passed to methods that only take an S3 object. (It seems like setOldClass() might be related to this but it's not clear to me from the documentation?)
e.g. for a minimal example imagine I have the S3 class and function:
myS3 <- list(a = 1, b = 2)
class(myS3) <- "myS3class"
myS3function.myS3class <- function(x) x$a + x$b
and I have the S4 object
setClass("myS4class", representation(a = "numeric", b = "numeric"))
obj <- new("myS4class", a = 1, b = 2)
Is there anything I can do such that
myS3function.myS3class(obj)
gives me same thing as
myS3function.myS3class(myS3)
by modifying only the S4 class?
Edit My rationale for this approach is to take advantage of all existing methods for the S3 class (that may generally come from other packages, etc) without having to rewrite them. I realize one approach is simply to write a coercion method (setAs()) that would turn my S4 object into and S3 object, but then a user would always have to perform this step manually. (While it works, I'm also a bit unclear whether it is bad practice to use setAs() to take an S4 class to an S3 class, rather than mapping between S4 classes).
From the way I read the documentation of setOldClass, it sounds like this can make S3 objects act like S4 objects? Is that correct? If so, my question then is if it possible to do the reverse (maybe by setting the prototype in the S4 class?).
If this is not possible, how about an explanation of the rationale why this would be a bad idea?
Add a method to your S4 class to convert it to being an S3 class.
setGeneric(
"as.myS3class",
function(object)
{
standardGeneric("as.myS3class")
}
)
setMethod(
"as.myS3class",
signature(object = "myS4class"),
function(object)
{
structure(list(a = object#a, b = object#b), class = "myS3class")
}
)
Then you can call the S3 method like this:
myS3function(as.myS3class(obj))
A successful solution is indeed buried in the documentation of setOldClass:
## Examples of S3 classes with guaranteed attributes
## an S3 class "stamped" with a vector and a "date" attribute
## Here is a generator function and an S3 print method.
## NOTE: it's essential that the generator checks the attribute classes
stamped <- function(x, date = Sys.time()) {
if(!inherits(date, "POSIXt"))
stop("bad date argument")
if(!is.vector(x))
stop("x must be a vector")
attr(x, "date") <- date
class(x) <- "stamped"
x
}
print.stamped <- function(x, ...) {
print(as.vector(x))
cat("Date: ", format(attr(x,"date")), "\n")
}
## Now, an S4 class with the same structure:
setClass("stamped4", contains = "vector", representation(date = "POSIXt"))
## We can use the S4 class to register "stamped", with its attributes:
setOldClass("stamped", S4Class = "stamped4")
selectMethod("show", "stamped")
## and then remove "stamped4" to clean up
removeClass("stamped4")
someLetters <- stamped(sample(letters, 10),
ISOdatetime(2008, 10, 15, 12, 0, 0))
st <- new("stamped", someLetters)
st
# show() method prints the object's class, then calls the S3 print method.
stopifnot(identical(S3Part(st, TRUE), someLetters))
# creating the S4 object directly from its data part and slots
new("stamped", 1:10, date = ISOdatetime(1976, 5, 5, 15, 10, 0))
Note that the S4 object can use the S3 print method. What surprised me is that this works for other methods that are defined for the S3 class but not the S4 class even without additional calls to selectMethod. I illustrate this with a more detailed example about my use case with ape::phylo object here: http://carlboettiger.info/2013/10/07/nexml-phylo-class-extension.html
If you want to reuse the one function for both S3 and S4 classes, and not change it, you can write your own definition for $:
f <- function(x, name)
slot(x, name)
setMethod("$", signature=c(x="myS4class"), definition=f)
myS3function.myS4class(obj)
# [1] 3
This seems rather dubious to me, though. For starters, you'll probably also need a similar method for [[, since a function could reference a list element either way:
setMethod("[[", signature=c(x="myS4class", i="character"),
definition=function(x, i) slot(x, i))
And you'll need methods for assignment as well:
setMethod("$<-", signature=c(x="myS4class", value="numeric"),
definition=function(x, name, value) `slot<-`(x, name, check=TRUE, value))
setMethod("[[<-", signature=c(x="myS4class", i="character", value="numeric"),
definition=function(x, i, value) `slot<-`(x, i, check=TRUE, value))
But then you have the problem of referencing by number:
obj[[1]]
# Error in obj[[1]] : this S4 class is not subsettable
So you need yet another method:
g <- function(x, i)
{
slots <- names(getClass("myS4class")#slots)
slot(x, slots[i])
}
setMethod("[[", signature=c(x="myS4class", i="numeric"), g)
All up, it seems like a lot of work for not much gain.

Resources