Need to estimate two parameters using the nlm function;
fit<-nlm(hood2par,c(x01[i],x02[j]),iterlim=300, catch=x[,c(3,4,5)],sp=.5)
where hood2par is a modified logistic
The convergence of nlm depends on the starting values of these parameters. To find such initial values I automatically generate two vectors of starting values
x01 = seq(-10,-20,-0.1)
x02 = seq(0.1,0.9,0.01)
next I create a routine included in a double for() to find the values that lead to the convergence of the function:
for (i in 1:length(x01)) { for (j in 1:length(x02)) {
fit <- NULL
try(fit <- nlm(hood2par, c(x01[i],x02[j]), iterlim = 300, catch = x[,c(3,4,5)],
sp = .5),
silent = TRUE)
stopifnot(is.null(fit))}}
The problem I have is that when I include the previous routine in a function:
FFF <- function(x01, x02, catch){
for (i in 1:length(x01)) {
for (j in 1:length(x02)) {
fit <- NULL
try(fit <- nlm(hood2par, c(x01[i], x02[j]), iterlim = 300,
catch = x[,c(3,4,5)], sp = .5),
silent = TRUE) # does not stop in the case of err
stopifnot(is.null(fit))
}
}
return(fit)
}
I can´t get the 'fit' values from FFF():
> fit.fff<-FFF(x01,x02,catch)
#Error: is.null(fit) is not TRUE
>fit.fff
fit.fff
Error: object 'fit.fff' not found
I used stopifnot(is.null(fit)) to stop the loops when fit is not NULL (as fit is defined as a NULL object before try(...)). Regarding the try code you have shared, I just need this;
res <- try(some_expression)
if(inherits(res, "try-error"))
{
#some code to keep loops running
} else
{
#stop the loops and gather "res"
}
I tried to include the break function in the second argument of the condictional, but it doesn´t run in my R version...Any idea??
When you call FFF, inside the try block if nlm successfully completes, then fit is assigned, and the stopifnot condition is activated, throwing an error.
Wildly guessing, did you mean
stopifnot(!is.null(fit))
For future reference, a standard chunk of code for use with try is
res <- try(some_expression)
if(inherits(res, "try-error"))
{
#some error handling code
} else
{
#normal execution
}
Related
I need to write a computer program which would look for whether two functions have the same minima points for given parameters, so I wanted to write program which would look for this on some example functions, which minima I know. So I wrote a program, but I get an error 'result$hessian':$ operator is invalid for atomic vectors all the time. But for these given examples, the hessian should be positive, defined, and definitelly non atomic. I don't know whether algorithm get stuck at local minimum or something. Here is the code:
find_min <- function(f) {
n_starts <- 10
min_points <- rep(NA, n_starts)
success <- FALSE
for (i in 1:n_starts) {
result <- tryCatch(optim(par = runif(3, min = -100, max = 100), function(x) -f(x), method = "L-BFGS-B", lower = -100, upper = 100, hessian = TRUE),
error = function(e) {
success <- FALSE
})
if (!is.null(result$hessian) && is.matrix(result$hessian) && any(eigen(result$hessian)$values <= 0)) {
min_points[i] <- NA
success <- FALSE
}
if (is.null(result$hessian)) {
min_points[i] <- NA
success <- FALSE
}
if (is.na(result$par) || !is.numeric(result$par)) {
min_points[i] <- NA
success <- FALSE
}
min_points[i] <- result$par
success <- TRUE
}
if (any(!is.na(min_points))) {
return(min_points[which.min(sapply(min_points, f))])
} else {
return(NA)
}
}
# example functions
f1 <- function(x) {
x[1]^2 + x[2]^2 + x[3]^2
}
f2 <- function(x) {
x[1]^4 + x[2]^4 + x[3]^4
}
min1 <- find_min(f1)
min2 <- find_min(f2)
if (is.na(min1[2]) || is.na(min2[2])) {
print(min1[1])
print(min2[1])
} else if (all(min1[2] == min2[2])) {
print("The minimum points are the same.")
} else if (!all(min1[2] == min2[2])) {
print("The minimum points are different.")
I tried to make sure that hessian is not an atomic vector by trying to catch some errors. I tried to use different starting points in order to get function unstuck if it is stuck at local minima. I tried giving it different example equations. I tried checking the order of if's in hessian checking. Tried to check if is.atomic throws out something but it doesn't even want to compile that. Please help because nothing worked...
result$par are the 3 parameters that optim was initialised with each time; yet you were attempting to place those at a single location of numeric vector (min_points); this is invalid.
but it seems to be not what you say what you wish to do any way.
you are not seeking the min_points you are surely seeking the min_values (reached by whatever points)
i.e.
min_points[i] <- result$value
you can then end the function by returning the minimum of min_points directly.
...
min_points[i] <- result$value
success <- TRUE
}
min(min_points)
}
of course you would probably want to go back and rename min_points to min_vals or whatever you think is descriptive.
making these recommended changes and given your examples results in the following
> min1
[1] -30000
> min2
[1] -3e+08
I have some loop that computes a value. Sometimes that computation triggers a warning. How do I check if the warning is triggered, then skip that iteration? I am using R.
With help from the comments, I found tryCatch() and was able to amend my for loop as the following and work:
for (i in seq(1,100,1)){
x<-sample(1:length(df$values), 1)
input<-copy_df[x:x+5,]
val<-tryCatch(myfunc(input$colA), warning=function(w) w)
if (is(val,warning){
next
}
print(paste0(i))
}
The output of val should be a column of length 5.
Here's a complete example using a test function that randomly generates a warning
set.seed(101)
foo <- function() {
x <- runif(1)
if(x<.9) warning("low x")
x
}
for(i in 1:20) {
didwarn <- tryCatch({x <- foo(); FALSE}, warning = function(w) return(TRUE))
if(didwarn) {
next
}
print(paste("high x", x))
}
You wrap any code that might trigger a warning in a try catch. Here we have each block return TRUE or FALSE depending on whether or not an error was thrown. An easier way to do this without the next would be
for(i in 1:20) {
tryCatch({
x <- foo();
print(paste("high x", x))
},
warning = function(w) {
# do nothing
})
}
When the warning occurs, nothing else in the tryCatch expression will run
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.
Please bear in mind that this is only my second day writing R code instead of using it, and I'm taking on a project almost surely above my level. A lot of my code is probably inefficient.
I'm trying to write R code which will automate the majority of my multiple regression analysis, while still allowing manual fine tuning in terms of the # of predictors, data transformations and model assumptions. I always get the error:
Error: could not find function "Dat.assumptn"
General advice on getting this nested function design to work is appreciated. Also, could someone please post a few well written links on functions in R which cover a range of difficulty?
As for my other issues, such as implementing pass by reference behavior via a package like R.oo from CRAN or a source from R: Pass by reference, I think I can figure it out. Here is a part of my code (incomplete and needs rewriting):
Dat.assumptn <- function(f, final, caperDS, picanDS) {
print(f)
crunchMod <- crunch(f, data = contrasts)
print(caic.table(crunchMod))
print(caic.diagnostics(crunchMod))
print(summary(crunchMod))
#If independent contrasts assumptions fail, return me to the second for loop
#within Dat.analysis() [Not Yet Implemented]
#Implement code to reduce and check the model (whether final = true/false)
if (final == TRUE) {
retry <- Dat.Msucess(crunchMod)
#The above function will recommend additional transformations if the final
#reduced model significantly violated model assumptions.
}
}
Dat.analysis <- function() {
treList <- dir(pattern="*.tre") //All of my phylogenetic tree files
caperDS <- read.table("dataSet.txt", header = TRUE)
picanDS <- read.table("dataSet.txt", row.names = 1, header = TRUE)
#Dat.assumptn() requires a different format from Dat.analysis()
#The loop below changes the names from my data set to be proper variable names
for (i in 1:length(names(picanDS))) {
varName <- gsub("_|[0-9]|\\.", "", names(picanDS)[i])
names(caperDS)[i+1] <- varName
names(picanDS)[i] <- varName
caperDS[,paste(varName,"2",sep="")] <- caperDS[i+1]*caperDS[i+1]
}
#Implement a for loop to transform the data based upon specifications from both
#Dat.assumptn() [called from Dat.analysis] and Dat.Msuccess [called from Dat.assumptn].
#Likely using pass by reference.
for (i in 1:length(treList)) {
myTrees = read.nexus(treList[i])
for (j in 1:length(myTrees)) {
cat(paste("\n\n", treList[i]))
print(multiPhylosignal(picanDS, myTrees[[j]]))
contrasts <- comparative.data(myTrees[[j]], caperDS, Species)
if (names(caperDS)[3] == "MedF" || names(caperDS)[3] == "MaxF") {
final <- FALSE
f <- as.formula(paste(paste(names(caperDS)[2],"~"),
paste(paste(paste("(",paste(names(caperDS)[4:(ncol(picanDS)+1)], collapse="+"))),")^2"),
paste("+", paste(names(caperDS)[(ncol(picanDS)+4):ncol(caperDS)], collapse = "+"))))
while (final == FALSE) {
f <- Dat.assumptn(f, final, caperDS, picanDS)
#Pass final by reference, and set to true if the final reduced model
#is achieved. Otherwise, iterate to reduce the model.
}
final <- FALSE
f <- as.formula(paste(paste(names(caperDS)[3],"~"),
paste(paste(paste("(",paste(names(caperDS)[4:(ncol(picanDS)+1)], collapse="+"))),")^2"),
paste("+", paste(names(caperDS)[(ncol(picanDS)+4):ncol(caperDS)], collapse = "+"))))
while (final == FALSE) {
f <- Dat.assumptn(f, final, caperDS, picanDS)
#Pass final by reference, and set to true if the final reduced model
#is achieved. Otherwise, iterate to reduce the model.
}
} else {
final <- FALSE
f <- as.formula(paste(paste(names(caperDS)[2],"~"),
paste(paste(paste("(",paste(names(caperDS)[3:(ncol(picanDS)+1)], collapse="+"))),")^2"),
paste("+", paste(names(caperDS)[(ncol(picanDS)+3):ncol(caperDS)], collapse = "+"))))
while (final == FALSE) {
f <- Dat.assumptn(f, final, caperDS, picanDS)
#Pass final by reference, and set to true if the final reduced model
#is achieved. Otherwise, iterate to reduce the model.
}
}
}
}
}
I am trying to produce different uniform numbers using the Lehmar random number generator. I believe I have done this but I have a problem in producing different numbers each time I execute this function. Below is the code I am trying to do and I will explain the problem further underneath it.
MODULUS <- 2147483647
MULTIPLIER <- 48271
put_Seed <- function(x)
{
x <- (if ( x > 0)
{
x%%MODULUS
}
else
{
1000*as.numeric(Sys.time())
}
)
}
T_val <- function(Rand)
{
Q <- floor(MODULUS / MULTIPLIER)
R <- MODULUS%%MULTIPLIER;
floor(MULTIPLIER*(Rand%%Q) - R*(Rand/Q))
}
New_Random_Seed <- function(T_value_i)
{
Random_Seed <- (if (T_value_i > 0)
{
T_value_i;
}
else
{
T_value_i + MODULUS
})
}
Random <- function(New_Seed)
{
New_Seed/MODULUS
}
uniform_num <- function(a, b, r)
{
a + (b - a) * r
}
Random_Seed <- put_Seed(123456789)
uni_num <- function(k)
{
Random_Seed <- put_Seed(k)
T_value <- T_val(Random_Seed)
Random_Seed <- New_Random_Seed(T_value)
uniform_num(0, 1, Random(Random_Seed))
}
test1 <- uni_num(Random_Seed)
test2 <- uni_num(Random_Seed)
test3 <- uni_num(Random_Seed)
#Results
#test1 = 0.05380306
#test2 = 0.05380306
#test3 = 0.05380306
What I am trying to do is whenever I run the uni_num function that each time, the Random_Seed gets updated and the uniform_num(0, 1, Random(Random_Seed)) line produces a random uniform number between 0 and 1 each time the function is executed. The code works for 1 repetition but if I try to use the function again the Random_Seed has not being updated and hence the function will produce the same random number as before. This is undesirable as I wish to produce different random number's each time by having the Random_Seed updated after each repetition. Forgive me if there is a simple solution but my head is wrecked from trying to find an answer. Cheers :)
In this function:
uni_num <- function(k)
{
Random_Seed <- put_Seed(k)
T_value <- T_val(Random_Seed)
Random_Seed <- New_Random_Seed(T_value)
uniform_num(0, 1, Random(Random_Seed))
}
The target of the assignment Random_Seed <- is in the environment of the function body, and not the global environment. Thus, when you make a second call, Random_Seed in the global environment has not been modified, and you get the same results.
To write to the global environment instead, use <<-:
Random_Seed <<- New_Random_Seed(T_value)
It looks like this is the only assignment that must be modified, as New_Random_Seed returns a value and doesn't require modification of this global object. In addition, the first assignment to Random_Seed in uni_num might as well be in the function body environment.
Note that it's bad form for a function to write to the global environment. There's always a better way. But this will work for your example code.