Reproducible example:
setClass("test", representation(a="ANY"))
A <- structure("blahblahblah", class="try-error")
new("test", a=A)
# Error in validObject(.Object) : invalid class “test” object: blahblahblah
I think the problem stems from line 29 of validObject:
sloti <- try(switch(namei, .S3Class = S3Class(object),
slot(object, namei)), silent = TRUE)
which clearly will trick whatever follows when slot(object, namei) returns a try-error class object as is the case here.
Anyhow, just wanted to ask here if this seems like a bug to anyone else before I go off and propose a tryCatch alternate.
And if you're curious as to why on earth I would be doing something like this, I am building S4 classes to store results of arbitrary expression evaluations, which in one of my test cases happened to contain the result of a try() statement.
No, the issue is on the next line:
if (inherits(sloti, "try-error")) {
errors <- c(errors, sloti)
next
}
A hacky workaround would be:
safeNew <- function(...) {
suppressMessages(trace(validObject, quote(inherits <- function(...)
if (eval.parent(substitute(namei != '.S3Class' && class(slot(object, namei)) == 'try-error'))) FALSE
else base::inherits(...)), at = 11))
capture.output(res <- new(...))
suppressMessages(untrace(validObject))
res
}
setClass("test", representation(a="ANY"))
A <- structure("blahblahblah", class="try-error")
safeNew("test", a = A) # Now returns no error.
EDIT: I changed some code above so it now type checks correctly rather than disable type checking. For example,
setClass("test", representation(a="ANY", b = "character"))
A <- structure("blahblahblah", class="try-error")
safeNew("test", a = A, b = 5)
# Error in validObject(.Object) :
# invalid class “test” object: invalid object for slot "b" in class "test": got class "numeric", should be or extend class "character"
Related
I have a regression model (lm or glm or lmer ...) and I do fitmodel <- lm(inputs) where inputs changes inside a loop (the formula and the data). Then, if the model function does not produce any warning I want to keep fitmodel, but if I get a warning I want to update the model and I want the warning not printed, so I do fitmodel <- lm(inputs) inside tryCatch. So, if it produces a warning, inside warning = function(w){f(fitmodel)}, f(fitmodel) would be something like
fitmodel <- update(fitmodel, something suitable to do on the model)
In fact, this assignation would be inside an if-else structure in such a way that depending on the warning if(w$message satisfies something) I would adapt the suitable to do on the model inside update.
The problem is that I get Error in ... object 'fitmodel' not found. If I use withCallingHandlers with invokeRestarts, it just finishes the computation of the model with the warning without update it. If I add again fitmodel <- lm(inputs) inside something suitable to do on the model, I get the warning printed; now I think I could try suppresswarnings(fitmodel <- lm(inputs)), but yet I think it is not an elegant solution, since I have to add 2 times the line fitmodel <- lm(inputs), making 2 times all the computation (inside expr and inside warning).
Summarising, what I would like but fails is:
tryCatch(expr = {fitmodel <- lm(inputs)},
warning = function(w) {if (w$message satisfies something) {
fitmodel <- update(fitmodel, something suitable to do on the model)
} else if (w$message satisfies something2){
fitmodel <- update(fitmodel, something2 suitable to do on the model)
}
}
)
What can I do?
The loop part of the question is because I thought it like follows (maybe is another question, but for the moment I leave it here): it can happen that after the update I get another warning, so I would do something like while(get a warning on update){update}; in some way, this update inside warning should be understood also as expr. Is something like this possible?
Thank you very much!
Generic version of the question with minimal example:
Let's say I have a tryCatch(expr = {result <- operations}, warning = function(w){f(...)} and if I get a warning in expr (produced in fact in operations) I want to do something with result, so I would do warning = function(w){f(result)}, but then I get Error in ... object 'result' not found.
A minimal example:
y <- "a"
tryCatch(expr = {x <- as.numeric(y)},
warning = function(w) {print(x)})
Error in ... object 'x' not found
I tried using withCallingHandlers instead of tryCatch without success, and also using invokeRestart but it does the expression part, not what I want to do when I get a warning.
Could you help me?
Thank you!
The problem, fundamentally, is that the handler is called before the assignment happens. And even if that weren’t the case, the handler runs in a different scope than the tryCatch expression, so the handler can’t access the names in the other scope.
We need to separate the handling from the value transformation.
For errors (but not warnings), base R provides the function try, which wraps tryCatch to achieve this effect. However, using try is discouraged, because its return type is unsound.1 As mentioned in the answer by ekoam, ‘purrr’ provides soundly typed functional wrappers (e.g. safely) to achieve a similar effect.
However, we can also build our own, which might be a better fit in this situation:
with_warning = function (expr) {
self = environment()
warning = NULL
result = withCallingHandlers(expr, warning = function (w) {
self$warning = w
tryInvokeRestart('muffleWarning')
})
list(result = result, warning = warning)
}
This gives us a wrapper that distinguishes between the result value and a warning. We can now use it to implement your requirement:
fitmodel = with(with_warning(lm(inputs)), {
if (! is.null(warning)) {
if (conditionMessage(warning) satisfies something) {
update(result, something suitable to do on the model)
} else {
update(result, something2 suitable to do on the model)
}
} else {
result
}
})
1 What this means is that try’s return type doesn’t distinguish between an error and a non-error value of type try-error. This is a real situation that can occur, for example, when nesting multiple try calls.
It seems that you are looking for a functional wrapper that captures both the returned value and side effects of a function call. I think purrr::quietly is a perfect candidate for this kind of task. Consider something like this
quietly <- purrr::quietly
foo <- function(x) {
if (x < 3)
warning(x, " is less than 3")
if (x < 4)
warning(x, " is less than 4")
x
}
update_foo <- function(x, y) {
x <- x + y
foo(x)
}
keep_doing <- function(inputs) {
out <- quietly(foo)(inputs)
repeat {
if (length(out$warnings) < 1L)
return(out$result)
cat(paste0(out$warnings, collapse = ", "), "\n")
# This is for you to see the process. You can delete this line.
if (grepl("less than 3", out$warnings[[1L]])) {
out <- quietly(update_foo)(out$result, 1.5)
} else if (grepl("less than 4", out$warnings[[1L]])) {
out <- quietly(update_foo)(out$result, 1)
}
}
}
Output
> keep_doing(1)
1 is less than 3, 1 is less than 4
2.5 is less than 3, 2.5 is less than 4
[1] 4
> keep_doing(3)
3 is less than 4
[1] 4
Are you looking for something like the following? If it is run with y <- "123", the "OK" message will be printed.
y <- "a"
#y <- "123"
x <- tryCatch(as.numeric(y),
warning = function(w) w
)
if(inherits(x, "warning")){
message(x$message)
} else{
message(paste("OK:", x))
}
It's easier to test several argument values with the code above rewritten as a function.
testWarning <- function(x){
out <- tryCatch(as.numeric(x),
warning = function(w) w
)
if(inherits(out, "warning")){
message(out$message)
} else{
message(paste("OK:", out))
}
invisible(out)
}
testWarning("a")
#NAs introduced by coercion
testWarning("123")
#OK: 123
Maybe you could assign x again in the handling condition?
tryCatch(
warning = function(cnd) {
x <- suppressWarnings(as.numeric(y))
print(x)},
expr = {x <- as.numeric(y)}
)
#> [1] NA
Perhaps not the most elegant answer, but solves your toy example.
Don't put the assignment in the tryCatch call, put it outside. For example,
y <- "a"
x <- tryCatch(expr = {as.numeric(y)},
warning = function(w) {y})
This assigns y to x, but you could put anything in the warning body, and the result will be assigned to x.
Your "what I would like" example is more complicated, because you want access to the expr value, but it hasn't been assigned anywhere at the time the warning is generated. I think you'll have to recalculate it:
fitmodel <- tryCatch(expr = {lm(inputs)},
warning = function(w) {if (w$message satisfies something) {
update(lm(inputs), something suitable to do on the model)
} else if (w$message satisfies something2){
update(lm(inputs), something2 suitable to do on the model)
}
}
)
Edited to add:
To allow the evaluation to proceed to completion before processing the warning, you can't use tryCatch. The evaluate package has a function (also called evaluate) that can do this. For example,
y <- "a"
res <- evaluate::evaluate(quote(x <- as.numeric(y)))
for (i in seq_along(res)) {
if (inherits(res[[i]], "warning") &&
conditionMessage(res[[i]]) == gettext("NAs introduced by coercion",
domain = "R"))
x <- y
}
Some notes: the res list will contain lots of different things, including messages, warnings, errors, etc. My code only looks at the warnings. I used conditionMessage to extract the warning message, but
it will be translated to the local language, so you should use gettext to translate the English version of the message for comparison.
I have an issue verifying the validity of my class 'class2'; it is made of a list of 'class1' objects. I want to verify that it is indeed the case:
class2 <- setClass(
Class = "class2",
slots = c(slotListName = "list"),
validity = function(object){
lapply(object#slotListName, function(x){
if(!identical(is(x), "class1"))
stop(" not a class1 object");
});
});
The problem is that lapply returns values which are not accepted:
Error in validObject(.Object) :
invalid class “class2” object: 1: NULL
invalid class “class2” object: 2: NULL
I checked that the problem was coming from the lapply by testing only the first element of the list, which is working fine:
if(!identical(is(object#slotListName[[1]]), "class1"))
stop("not a class1 object");
I tried vectorizing but this does not change the problem.
Is there a way to verify that slotListName is indeed a list of 'class1' objects?
Thanks a lot!
The problem with your function is that it gives an error for an invalid object. It's supposed to return a diagnostic message, with the S4 object construction machinery taking care of the error.
Here's how you can do it using the recommended approach, which is to define methods for initialize and setValidity. See ?setClass for more details.
class2 <- setClass("class2", slots=c(slotListName="list"))
setMethod("initialize", "class2", function(.Object, lst)
{
.Object#slotListName <- lst
validObject(.Object)
.Object
})
# returns TRUE if the object is valid, otherwise a diagnostic message
setValidity("class2", function(object)
{
if(length(object#slotListName) < 1)
"must contain at least one class1 object"
else if(!all(sapply(object#slotListName, function(x) inherits(x, "class1"))))
"all objects in list must be class1"
else TRUE
})
## testing
x <- 42
class(x) <- "class1"
y <- 43
class(y) <- "bad"
l1 <- list(x, x, x)
l2 <- list(x, x, y)
## works
obj1 <- class2(l1)
## error: bad object in list
obj2 <- class2(l2)
## error: empty list
obj3 <- class2(list())
So I'm changing the class of some functions that I'm building in R in order to add a description attribute and because I want to use S3 generics to handle everything for me. Basically, I have a structure like
foo <- function(x) x + 1
addFunction <- function(f, description) {
class(f) <- c("addFunction", "function")
attr(f, "description") <- description
f
}
foo <- addFunction(foo, "Add one")
and then I do stuff like
description <- function(x) UseMethod("description")
description.default <- function(x) deparse(substitute(x))
description.addFunction <- function(x) attr(x, "description")
This works fine, but it's not that elegant. I'm wondering if it is possible to define a new class of functions such that instances of this class can be defined in a syntax similar to the function syntax. In other words, is it possible to define addFunction such that foo is generated in the following way:
foo <- addFunction(description = "Add one", x) {
x + 1
}
(or something similar, I have no strong feelings about where the attribute should be added to the function)?
Thanks for reading!
Update: I have experimented a bit more with the idea, but haven't really reached any concrete results yet - so this is just an overview of my current (updated) thoughts on the subject:
I tried the idea of just copying the function()-function, giving it a different name and then manipulating it afterwards. However, this does not work and I would love any inputs on what is happening here:
> function2 <- `function`
> identical(`function`, function2)
[1] TRUE
> function(x) x
function(x) x
> function2(x) x
Error: unexpected symbol in "function2(x) x"
> function2(x)
Error: incorrect number of arguments to "function"
As function() is a primitive function, I tried looking at the C-code defining it for more clues. I was particularly intrigued by the error message from the function2(x) call. The C-code underlying function() is
/* Declared with a variable number of args in names.c */
SEXP attribute_hidden do_function(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP rval, srcref;
if (TYPEOF(op) == PROMSXP) {
op = forcePromise(op);
SET_NAMED(op, 2);
}
if (length(args) < 2) WrongArgCount("function");
CheckFormals(CAR(args));
rval = mkCLOSXP(CAR(args), CADR(args), rho);
srcref = CADDR(args);
if (!isNull(srcref)) setAttrib(rval, R_SrcrefSymbol, srcref);
return rval;
}
and from this, I conclude that for some reason, at least two of the four arguments call, op, args and rho are now required. From the signature of do_function() I am guessing that the four arguments passed to do_function should be a call, a promise, a list of arguments and then maybe an environment. I tried a lot of different combinations for function2 (including setting up to two of these arguments to NULL), but I keep getting the same (new) error message:
> function2(call("sum", 2, 1), NULL, list(x=NULL), baseenv())
Error: invalid formal argument list for "function"
> function2(call("sum", 2, 1), NULL, list(x=NULL), NULL)
Error: invalid formal argument list for "function"
This error message is returned from the C-function CheckFormals(), which I also looked up:
/* used in coerce.c */
void attribute_hidden CheckFormals(SEXP ls)
{
if (isList(ls)) {
for (; ls != R_NilValue; ls = CDR(ls))
if (TYPEOF(TAG(ls)) != SYMSXP)
goto err;
return;
}
err:
error(_("invalid formal argument list for \"function\""));
}
I'm not fluent in C at all, so from here on I'm not quite sure what to do next.
So these are my updated questions:
Why do function and function2 not behave in the same way? Why
do I need to call function2 using a different syntax when they are
deemed identical in R?
What are the proper arguments of function2
such that function2([arguments]) will actually define a function?
Some keywords in R such as if and function have special syntax in the way that the underlying functions get called. It's quite easy to use if as a function if desired, e.g.
`if`(1 == 1, "True", "False")
is equivalent to
if (1 == 1) {
"True"
} else {
"False"
}
function is trickier. There's some help on this at a previous question.
For your current problem here's one solution:
# Your S3 methods
description <- function(x) UseMethod("description")
description.default <- function(x) deparse(substitute(x))
description.addFunction <- function(x) attr(x, "description")
# Creates the pairlist for arguments, handling arguments with no defaults
# properly. Also brings in the description
addFunction <- function(description, ...) {
args <- eval(substitute(alist(...)))
tmp <- names(args)
if (is.null(tmp)) tmp <- rep("", length(args))
names(args)[tmp==""] <- args[tmp==""]
args[tmp==""] <- list(alist(x=)$x)
list(args = as.pairlist(args), description = description)
}
# Actually creates the function using the structure created by addFunction and the body
`%{%` <- function(args, body) {
stopifnot(is.pairlist(args$args), class(substitute(body)) == "{")
f <- eval(call("function", args$args, substitute(body), parent.frame()))
class(f) <- c("addFunction", "function")
attr(f, "description") <- args$description
f
}
# Example. Note that the braces {} are mandatory even for one line functions
foo <- addFunction(description = "Add one", x) %{% {
x + 1
}
foo(1)
#[1] 2
let's assume you have one S4 class "A", and a subclass "B" which has additional features. Each have their own validity checks in place - B should only check the additional features. Now in the initialization of B, I would like to start out from an object of class A, and then amend it with the additional features. However, this creates problems, and I guess I am somewhere violating R's assumptions in this example.
Here's the dummy code:
setClass(Class="A",
representation=
representation(x="numeric"),
validity=
function(object){stopifnot(x > 0)})
setMethod("initialize",
signature(.Object="A"),
function(.Object,
...,
z){
x <- get("z") + 1
callNextMethod(.Object,
...,
x=x)
})
setClass(Class="B",
contains="A",
representation=
representation(y="numeric"),
validity=
function(object){stopifnot(y > 0)})
setMethod("initialize",
signature(.Object="B"),
function(.Object,
...,
bla){
.Object <- callNextMethod(.Object,
...)
.Object#y <- .Object#x + bla
return(.Object)
})
test <- new("B",
z=4,
bla=5)
If I try to create the "test" object, I get:
Error in stopifnot(x > 0): object 'x' not found
Do you know how I could do better?
Thanks a lot in advance!
Best regards
Daniel
A convenient test of the assumptions in S4 is that new() called with no arguments on a non-VIRTUAL class needs to return a valid object. Your class does not pass this test
> validObject(new("A"))
Error in get("z") : argument "z" is missing, with no default
One option would provide a default value to z in the initialize method, or (my preference) to use a prototype in the class definition coupled with a constructor. Also the validity function is supposed to return TRUE (if valid) or a character vector describing how it is not valid. So I wrote your class 'A' as
.A <- setClass(Class="A",
representation(x="numeric"),
prototype(x=1),
validity= function(object) {
msg <- NULL
if (length(object#x) != 1 || object#x <= 0)
msg <- c(msg, "'x' must be length 1 and > 0")
if (is.null(msg)) TRUE else msg
})
(the return value of setClass() just wraps new() in a more semantically rich function call).
> validObject(.A())
[1] TRUE
Instead of using the initialize method (which is tricky to implement correctly -- it's a copy constructor as well) I'd write
A <- function(z, ...)
.A(x=z+1, ...)
which behaves as expected
> A()
Error in initialize(value, ...) (from valid.R!7685pfr#2) :
argument "z" is missing, with no default
> A(1)
An object of class "A"
Slot "x":
[1] 2
I think the extension of these principles to "B" should be straight-forward, and a good "exercise for the reader"!
Just to complete Martin's answer, here is the full solution to my problem:
.A <- setClass(Class="A",
representation(x="numeric"),
prototype(x=1),
validity=
function(object){
msg <- NULL
if (length(object#x) != 1 || object#x <= 0)
msg <- c(msg, "'x' must be length 1 and > 0")
if (is.null(msg)) TRUE else msg
})
validObject(.A())
A <- function(z, ...)
{
x <- z + 1
.A(x=x, ...)
}
.B <- setClass(Class="B",
representation(y="numeric"),
prototype(y=2),
contains="A",
validity=
function(object){
msg <- NULL
if (length(object#y) != 1 || object#y <= 0)
msg <- c(msg, "'y' must be length 1 and > 0")
if (is.null(msg)) TRUE else msg
})
validObject(.B())
B <- function(bla, z, ...)
{
obj <- A(z, ...)
y <- obj#x + bla
.B(obj, y=y, ...)
}
test <- B(z=4,
bla=5)
Thanks again Martin for the extremely fast and perfect help!
best regards
Daniel
I am using stopifnot and I understand it just returns the first value that was not TRUE. I f that is some freaky dynamic expression someone who is not into the custom function cannot really make something out of that. So I would love to add a custom error message. Any suggestions?
Error: length(unique(nchar(check))) == 1 is not TRUE
Basically states that the elements of the vector check do not have the same length.
Is there a way of saying: Error: Elements of your input vector do not have the same length!?
Use stop and an if statement:
if(length(unique(nchar(check))) != 1)
stop("Error: Elements of your input vector do not have the same length!")
Just remember that stopifnot has the convenience of stating the negative, so your condition in the if needs to be the negation of your stop condition.
This is what the error message looks like:
> check = c("x", "xx", "xxx")
> if(length(unique(nchar(check))) != 1)
+ stop("Error: Elements of your input vector do not have the same length!")
Error in eval(expr, envir, enclos) :
Error: Elements of your input vector do not have the same length!
A custom message can be added as a label to your expression:
stopifnot("Elements of your input vector do not have the same length!" =
length(unique(nchar(check))) == 1)
# Error: Elements of your input vector do not have the same length!
The assertive and assertthat packages have more readable check functions.
library(assertthat)
assert_that(length(unique(nchar(check))) == 1)
## Error: length(unique(nchar(check))) == 1 are not all true.
library(assertive)
assert_is_scalar(unique(nchar(check)))
## Error: unique(nchar(check)) does not have length one.
if(!is_scalar(unique(nchar(check))))
{
stop("Elements of check have different numbers of characters.")
}
## Error: Elements of check have different numbers of characters.
Or you could package it up.
assert <- function (expr, error) {
if (! expr) stop(error, call. = FALSE)
}
So you have:
> check = c("x", "xx", "xxx")
> assert(length(unique(nchar(check))) == 1, "Elements of your input vector do not have the same length!")
Error: Elements of your input vector do not have the same length!
What about embedding the stopifnot into tryCatch and then recasting the exception with stop using customized message?
Something like:
tryCatch(stopifnot(...,error=stop("Your customized error message"))
Unlike some other solutions this does not require additional packages. Compared to using if statement combined with stop you retain the performance advantages of stopifnot, when you use new R versions. Since R version 3.5.0 stopifnot evaluates expressions sequentially and stops on first failure.
I would recommend you check out Hadley's testthat package. It allows for intuitive testing: the names of the functions are great and the way you write them is like a sentence -- "I expect that length(unique(nchar(check))) is [exactly|approximately] 1". The errors produced are informative.
See here:
http://journal.r-project.org/archive/2011-1/RJournal_2011-1_Wickham.pdf
In your case,
> library(testthat)
> check = c("x", "xx", "xxx")
> expect_that(length(unique(nchar(check))), equals(1))
Error: length(unique(nchar(check))) not equal to 1
Mean relative difference: 2
Also note that you don't have the problem that #Andrie referenced with sometimes having to think about double negatives with stopifnot. I know it seems simple, but it caused me many headaches!
The answers already provided are quite good, and mine is just an addition to that collection. For some people it could be more convenient to use one-liner in form of the following function:
stopifnotinform <- function(..., message = "err") {
args <- list(...)
if (length(args) == 0) {
return(NULL)
}
for (i in 1:length(args)) {
result <- args[[i]]
if (is.atomic(result) && result == FALSE) {
stop(message)
}
}
}
# throws an error
stopifnotinform(is.integer(1L), is.integer(2), message = "Some number(s) provided is not an integer")
# continues with execution
stopifnotinform(is.integer(1L), is.integer(2L), message = "Some number(s) provided is not an integer")
Bear in mind that this solution provides you with only one (common) error message for all parameters in ....
Try this:
same_length <- FALSE
stopifnot("Elements of your input vector do not have the same length!" = same_length)
#> Error : Elements of your input vector do not have the same length!