Function raise error with return statement - r

I want to process a own designed function on every cell using the calc function of the "raster" package.
Everything works perfectly when I try to print the "final" result of the function (value I want to return), but when I try to use return statement, I got an error :
Error in .local(x, values, ...) :
values must be numeric, integer or logical.
Here is the code leading to that error
inR <- 'D://test/TS_combined_clipped.tif'
outR <- 'D://test/R_test3.tif'
rasterB <- brick(inR)
fun1 <-function(x){
years = seq(1, 345)
na_idx = which(is.na(x))
years = years[-na_idx]
x <- na.omit(x)
idx = detectChangePoint(x, cpmType='Student', ARL0=500)$changePoint
return(years[idx]) # this raises error
# print(years[idx]) # This does *not* raises any error
}
r <- calc(rasterB, fun=fun1, filename=outR, overwrite=TRUE)
How is it possible to have a return statement to make it fails ?
Some of my tests leads to the fact that it seems that the process fails just after the execution of the calc function on the very last cell of the rasterBrick.
But I have no clue of where to start to try to fix this.
Input image is available here
[EDIT]
I just noticed that if I use return(idx) instead of return(year[idx]) the process works without error raised.
So it seems that the problem is more at fetching the value of the year variable.
Is therefore any particular thing that I missed in the use of indexes with R ?

Comment of user2554330 put me on the good track, issue was that calc cannot handle a "numeric(0)" result.
Updated code is then
inR <- 'D://test/TS_combined_clipped.tif'
outR <- 'D://test/R_test3.tif'
rasterB <- brick(inR)
fun1 <-function(x){
years = seq(1, 345)
na_idx = which(is.na(x))
years = years[-na_idx]
x <- na.omit(x)
idx = detectChangePoint(x, cpmType='Student', ARL0=500)$changePoint
if (idx==0){
return(0)
} else {
return(as.integer(years[idx]))
}
}
r <- calc(rasterB, fun=fun1, filename=outR, overwrite=TRUE)

Related

$ operator is invalid for atomic vectors in R after using data.frame()

I have read several posts about this problem in r and I think I have understood the reason behind it. However, after adjusting, my code still shows an error message. This code is based on what my friend told me.
get_ETA <- function(lineId, stationName) {
path_1 <- paste0("https://api.tfl.gov.uk/Line/", lineId, "/arrivals")
response_1 <- GET(path_1)
content_1 <- data.frame(content(response_1))
if (status_code(response_1) >= 400) stop("Error:typo in line Id")
for (i in 1:length(content_1)) {
if (content_1[[i]]$stationName == stationName) break
}
naptanId <- content_1[[i]]$naptanId
path_2 <- paste0("https://api.tfl.gov.uk/Line/", lineId, "/arrivals", naptanId)
response_2 <- GET(path_2)
content_2 <- data.frame(content(response_2))
eta <- c()
for (i in 1:length(content_2)) {
eta[i] <- content_2[[i]]$expectedArrival
}
return(sort(eta)[1])
}
And the error is 'Error: $ operator is invalid for atomic vectors'.
When I try some individual code, for instance
e <- GET("https://api.tfl.gov.uk/Line/northern/arrivals")
response <- content(e)
response[[2]]$stationName
There seems to be no such an error. Could someone help me fix it?
It seems a crucial term is missing on the ninth line.
naptanId <- content_1$matches[[i]]$naptanId

R: Not able to trycatch error with lapply

I have a table with stocks in R where I want to calculate the 6 month return based on tq_get and tiingo API. I wanted to use lapply to fill my table but unfortunately some tickers are not available on tiingo or maybe are wrong which returns an error. With this error the assigned data has less rows then the existing data and lapply is not working. I tried to resolve with tryCatch but it's still not working. What is missing?
today <- Sys.Date()
yesterday <- as.Date(today) - days(1)
before <- as.Date(today) - months(6)
tiingo_api_key('<my API key')
calculate <- function (x) {
((tq_get(x, get = "tiingo", from = yesterday, to = yesterday)$adjusted)/(tq_get(x, get = "tiingo", from = before, to = before)$adjusted)-1)
}
top10[20] <- lapply(top10[1], calculate(x) tryCatch(calculate(x), error=function(e) NA))
You need to move the function inside tryCatch. tryCatch wraps your function and catches errors. This should work.
# Old version vvvvvv function call in wrong place
top10[20] <- lapply(top10[1], calculate(x) tryCatch(calculate(x), error=function(e) NA))
# Corrected version
top10[20] <- lapply(top10[1], function(x) tryCatch(calculate(x), error=function(e) NA))
EDIT: #rawr already suggested this in a comment, I just saw. I only added a brief explanation of the function.
With including is_supported_ticker() from package riingo a workaround is possible to avoid the error message.
calculate <- function (x) {
supported = sapply(x, is_supported_ticker, type = "tiingo")
result = rep(NA, length(x))
result[supported] =
(
tq_get(x[supported], get = "tiingo", from = yesterday, to = yesterday)$adjusted /
tq_get(x[supported], get = "tiingo", from = before, to = before)$adjusted
) - 1
return(result)
}

Is there a way to use tryCatch (or similar) in R as a loop, or to manipulate the expr in the warning argument?

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.

Why would this 'sapply' function in R return an invalid response given my function?

CountNew <- function(x){
if (x==0) y <- 1
return(y)
}
allCF$NewECount >- sapply(allCF$Count, CountNew)
Using the above code, if a value in EquipCount in allCF is currently equal to 0, I want to change it to 1 while keeping the other values the same, then maintain the values of the rest of the values not equal to 0. I made sure these were numbers (not factors) through the str(rawCF) command
But then I get the following error:
Error in FUN(X[[i]], ...) : object 'y' not found
What is causing this problem?
The code logic is wrong.
What if the element does not satisfy x==0? The function will return a y which is not defined. Add one line will solve it:
Solution 1
allCF <- data.frame(Count=c(0,0,-1))
CountNew <- function(x){
y=x
if (x==0) y = 1
return(y);
}
allCF$NewECount <- sapply(allCF$Count, CountNew)
Solution 2: Vectorize your CountNew function
allCF <- data.frame(Count=c(0,0,-1))
CountNew <- Vectorize(function(x){
if (x==0) return(1);
return(x);
}
)
allCF$NewECount <- sapply(allCF$Count, CountNew)
Now you may do CountNew(allCF$Count) directly.

How to debug "invalid subscript type 'list'" error in R (genalg package)

I am new to genetic algorithms and am trying a simple variable selection code based on the example on genalg package's documentation:
data(iris)
library(MASS)
X <- cbind(scale(iris[,1:4]), matrix(rnorm(36*150), 150, 36))
Y <- iris[,5]
iris.evaluate <- function(indices) {
result = 1
if (sum(indices) > 2) {
huhn <- lda(X[,indices==1], Y, CV=TRUE)$posterior
result = sum(Y != dimnames(huhn)[[2]][apply(huhn, 1,
function(x)
which(x == max(x)))]) / length(Y)
}
result
}
monitor <- function(obj) {
minEval = min(obj$evaluations);
plot(obj, type="hist");
}
woppa <- rbga.bin(size=40, mutationChance=0.05, zeroToOneRatio=10,
evalFunc=iris.evaluate, verbose=TRUE, monitorFunc=monitor)
The code works just fine on its own, but when I try to apply my dataset (here), I get the following error:
X <- reducedScaledTrain[,-c(541,542)]
Y <- reducedScaledTrain[,542]
ga <- rbga.bin(size=540, mutationChance=0.05, zeroToOneRatio=10,
evalFunc=iris.evaluate, verbose=TRUE, monitorFunc=monitor)
Testing the sanity of parameters...
Not showing GA settings...
Starting with random values in the given domains...
Starting iteration 1
Calucating evaluation values... Error in dimnames(huhn)[[2]][apply(huhn, 1, function(x) which(x == max(x)))] :
invalid subscript type 'list'
I am trying to perform feature selection on 540 variables (I've eliminated the variables with 100% correlation) using LDA. I've tried transforming my data into numeric or list, but to no avail. I have also tried entering the line piece by piece, and the 'huhn' line works just fine with my data. Please help, I might be missing something...

Resources