R - Register the Errors as a new Variable/Vector/Column - r

I am learning the basics of R and I am currently using tryCatch to continue a loop even when an error is encountered. It basically looks like this:
for (variableloop in (1:10000)){
tryCatch({
My function/ formula goes here
},error=function(e){cat("ERROR :",conditionMessage(e), "\n")})
}
I was wondering if there is a command to save up the list of cases where the loop provided an error.
Thank you very much for your time.

What you want is to for each call to your function to return both the result and the error, where exactly one of the two is empty. Something like this (using base R):
# bigger loop than this ...
input <- 1:5
myfunc <- function(ign) if ( (x <- runif(1)) < 0.2) stop(paste0("some error: ", x)) else x
set.seed(2)
ret <- lapply(input, function(i) {
tryCatch(list(result = myfunc(i), error = NA),
error = function(e) list(result = NA, error = e))
})
str(ret)
# List of 5
# $ :List of 2
# ..$ result: logi NA
# ..$ error :List of 2
# .. ..$ message: chr "some error: 0.18488225992769"
# .. ..$ call : language myfunc(i)
# .. ..- attr(*, "class")= chr [1:3] "simpleError" "error" "condition"
# $ :List of 2
# ..$ result: num 0.702
# ..$ error : logi NA
# $ :List of 2
# ..$ result: num 0.573
# ..$ error : logi NA
# $ :List of 2
# ..$ result: logi NA
# ..$ error :List of 2
# .. ..$ message: chr "some error: 0.168051920365542"
# .. ..$ call : language myfunc(i)
# .. ..- attr(*, "class")= chr [1:3] "simpleError" "error" "condition"
# $ :List of 2
# ..$ result: num 0.944
# ..$ error : logi NA
You can access just the (possibly empty) errors with:
str(lapply(ret, `[[`, "error"))
# List of 5
# $ :List of 2
# ..$ message: chr "some error: 0.18488225992769"
# ..$ call : language myfunc(i)
# ..- attr(*, "class")= chr [1:3] "simpleError" "error" "condition"
# $ : logi NA
# $ : logi NA
# $ :List of 2
# ..$ message: chr "some error: 0.168051920365542"
# ..$ call : language myfunc(i)
# ..- attr(*, "class")= chr [1:3] "simpleError" "error" "condition"
# $ : logi NA
You can also use the purrr package:
set.seed(2)
ret <- lapply(input, function(i) {
purrr::safely(myfunc)(i)
})
str(lapply(ret, `[[`, "error"))
# List of 5
# $ :List of 2
# ..$ message: chr "some error: 0.18488225992769"
# ..$ call : language .f(...)
# ..- attr(*, "class")= chr [1:3] "simpleError" "error" "condition"
# $ : NULL
# $ : NULL
# $ :List of 2
# ..$ message: chr "some error: 0.168051920365542"
# ..$ call : language .f(...)
# ..- attr(*, "class")= chr [1:3] "simpleError" "error" "condition"
# $ : NULL

Related

Insert elements into a list based on depth and `if` conditions using modify_depth and modify_if (purrr)

I'm learning some purrr commands, specifically the modify_* family of functions. I'm attemping to add price bins to items found in a grocery store (see below for my attempt and error code).
library(tidyverse)
Data
easybuy <- list(
"5520 N Division St, Spokane, WA 99208, USA",
list("bananas", "oranges"),
canned = list("olives", "fish", "jam"),
list("pork", "beef"),
list("hammer", "tape")
) %>%
map(list) %>%
# name the sublists
set_names(c("address",
"fruit",
"canned",
"meat",
"other")) %>%
# except for address, names the sublists "items"
modify_at(c(2:5), ~ set_names(.x, "items"))
Take a peek:
glimpse(easybuy)
#> List of 5
#> $ address:List of 1
#> ..$ : chr "5520 N Division St, Spokane, WA 99208, USA"
#> $ fruit :List of 1
#> ..$ items:List of 2
#> .. ..$ : chr "bananas"
#> .. ..$ : chr "oranges"
#> $ canned :List of 1
#> ..$ items:List of 3
#> .. ..$ : chr "olives"
#> .. ..$ : chr "fish"
#> .. ..$ : chr "jam"
#> $ meat :List of 1
#> ..$ items:List of 2
#> .. ..$ : chr "pork"
#> .. ..$ : chr "beef"
#> $ other :List of 1
#> ..$ items:List of 2
#> .. ..$ : chr "hammer"
#> .. ..$ : chr "tape"
My Attempt
Idea: go in a depth of two, and look for "items", append a "price". I'm not sure if I can nest the modify functions like this.
easybuy %>%
modify_depth(2, ~ modify_at(., "items", ~ append("price")))
#> Error: character indexing requires a named object
Desired
I would like the following structure (note the addition of "price" under each item):
List of 5
$ address:List of 1
..$ : chr "5520 N Division St, Spokane, WA 99208, USA"
$ fruit :List of 1
..$ items:List of 2
.. ..$ :List of 2
.. .. ..$ : chr "bananas"
.. .. ..$ : chr "price"
.. ..$ :List of 2
.. .. ..$ : chr "oranges"
.. .. ..$ : chr "price"
$ canned :List of 1
..$ items:List of 3
.. ..$ :List of 2
.. .. ..$ : chr "olives"
.. .. ..$ : chr "price"
.. ..$ :List of 2
.. .. ..$ : chr "fish"
.. .. ..$ : chr "price"
.. ..$ :List of 2
.. .. ..$ : chr "jam"
.. .. ..$ : chr "price"
$ meat :List of 1
..$ items:List of 2
.. ..$ :List of 2
.. .. ..$ : chr "pork"
.. .. ..$ : chr "price"
.. ..$ :List of 2
.. .. ..$ : chr "beef"
.. .. ..$ : chr "price"
$ other :List of 1
..$ items:List of 2
.. ..$ :List of 2
.. .. ..$ : chr "hammer"
.. .. ..$ : chr "price"
.. ..$ :List of 2
.. .. ..$ : chr "tape"
.. .. ..$ : chr "price"
This seems working. The map_if and function(x) !is.null(names(x)) make sure the change only happen if the name of the item is not NULL. ~modify_depth(.x, 2, function(y) list(y, "price")) creates the list you need.
library(tidyverse)
easybuy2 <- easybuy %>%
map_if(function(x) !is.null(names(x)),
~modify_depth(.x, 2, function(y) list(y, "price")))
Here is how the second item looks like.
easybuy2[[2]][[1]]
# [[1]]
# [[1]][[1]]
# [1] "bananas"
#
# [[1]][[2]]
# [1] "price"
#
#
# [[2]]
# [[2]][[1]]
# [1] "oranges"
#
# [[2]][[2]]
# [1] "price"
Or this also works.
easybuy3 <- easybuy %>%
modify_at(2:5, ~modify_depth(.x, 2, function(y) list(y, "price")))
identical(easybuy2, easybuy3)
# [1] TRUE
Update
easybuy4 <- easybuy %>%
map_if(function(x){
name <- names(x)
if(is.null(name)){
return(FALSE)
} else {
return(name %in% "items")
}
},
~modify_depth(.x, 2, function(y) list(y, "price")))
identical(easybuy2, easybuy4)
# [1] TRUE

Control the structure of a nested list when apply FUN returns list or NA

I have a vector v and matrix m and use apply to extract a subset of results from cor.test function (correlations between v and m columns).
set.seed(1)
m <- matrix(runif(12), nrow = 3)
v <- 3:1
res <- apply(m, 2, function(x) {
cor.test(x, v, method = 'spearman', exact = F)[c(1,3,4)]
})
This is a nested list of list with length equal to the number of columns in m - and in the structure I would like as output (2-level list).
> str(res)
List of 4
$ :List of 3
..$ statistic: Named num 8
.. ..- attr(*, "names")= chr "S"
..$ p.value : num 0
..$ estimate : Named num -1
.. ..- attr(*, "names")= chr "rho"
$ :List of 3
..$ statistic: Named num 2
.. ..- attr(*, "names")= chr "S"
..$ p.value : num 0.667
..$ estimate : Named num 0.5
.. ..- attr(*, "names")= chr "rho"
$ :List of 3
..$ statistic: Named num 0
.. ..- attr(*, "names")= chr "S"
..$ p.value : num 0
..$ estimate : Named num 1
.. ..- attr(*, "names")= chr "rho"
$ :List of 3
..$ statistic: Named num 6
.. ..- attr(*, "names")= chr "S"
..$ p.value : num 0.667
..$ estimate : Named num -0.5
.. ..- attr(*, "names")= chr "rho"
I want to filter each cor.test result, say the p.value, within the apply loop and return NA to indicate filtered results (retaining the length of the result, here four).
res <- apply(m, 2, function(x) {
tmp <- cor.test(x, v, method = 'spearman', exact = F)[c(1,3,4)]
ifelse(tmp$p.value < 0.1, list(tmp), NA)
})
My problem is that we now get a 3-level list structure
res2 <- apply(m, 2, function(x) {
tmp <- cor.test(x, v, method = 'spearman', exact = F)[c(1,3,4)]
ifelse(tmp$p.value < 0.1, list(tmp), NA)
})
> str(res2)
List of 4
$ :List of 1
..$ :List of 3
.. ..$ statistic: Named num 8
.. .. ..- attr(*, "names")= chr "S"
.. ..$ p.value : num 0
.. ..$ estimate : Named num -1
.. .. ..- attr(*, "names")= chr "rho"
$ : logi NA
$ :List of 1
..$ :List of 3
.. ..$ statistic: Named num 0
.. .. ..- attr(*, "names")= chr "S"
.. ..$ p.value : num 0
.. ..$ estimate : Named num 1
.. .. ..- attr(*, "names")= chr "rho"
$ : logi NA
Only if the first result from apply is NA the result structure is like desired, obviously since apply then can fit unfiltered result to the structure.
res3 <- apply(m, 2, function(x) {
tmp <- cor.test(x, v, method = 'spearman', exact = F)[c(1,3,4)]
ifelse(tmp$p.value > 0.1, list(tmp), NA) #'invert' the test
})
>res3
List of 4
$ : logi NA
$ :List of 3
..$ statistic: Named num 2
.. ..- attr(*, "names")= chr "S"
..$ p.value : num 0.667
..$ estimate : Named num 0.5
.. ..- attr(*, "names")= chr "rho"
$ : logi NA
$ :List of 3
..$ statistic: Named num 6
.. ..- attr(*, "names")= chr "S"
..$ p.value : num 0.667
..$ estimate : Named num -0.5
.. ..- attr(*, "names")= chr "rho"
I have tried to return ifelse(tmp$p.value < 0.1, tmp, NA) and ifelse(tmp$p.value < 0.1, list(tmp), list(NA)) in vain.
The only solution I found is to assign NA outside the apply:
res4 <- apply(m, 2, function(x) {
cor.test(x, v, method = 'spearman', exact = F)[c(1,3,4)]
})
res4[sapply(res4, "[[", 2) > 0.1] <- NA
Clearly, I miss something about the inner workings of apply.
Your issue isn't with apply but with ifelse. If you use if () {} else {} instead, it works the way you intend
res3 <- apply(m, 2, function(x) {
tmp <- cor.test(x, v, method = 'spearman', exact = F)[c(1,3,4)]
if (tmp$p.value < 0.1) { return(tmp) } else { return(NA) }
})
str(res3)
# List of 4
# $ :List of 3
# ..$ statistic: Named num 8
# .. ..- attr(*, "names")= chr "S"
# ..$ p.value : num 0
# ..$ estimate : Named num -1
# .. ..- attr(*, "names")= chr "rho"
# $ : logi NA
# $ :List of 3
# ..$ statistic: Named num 0
# .. ..- attr(*, "names")= chr "S"
# ..$ p.value : num 0
# ..$ estimate : Named num 1
# .. ..- attr(*, "names")= chr "rho"
# $ : logi NA
Note documentation from ifelse
ifelse returns a value with the same shape as test

Removing elements in a nested R list by name

I have a nested element like this
> x <- list(a=list(from="me", id="xyz"), b=list(comment=list(list(message="blabla", id="abc"), list(message="humbug", id="jkl"))), id="123")
> str(x)
List of 3
$ a :List of 2
..$ from: chr "me"
..$ id : chr "xyz"
$ b :List of 1
..$ comment:List of 2
.. ..$ :List of 2
.. .. ..$ message: chr "blabla"
.. .. ..$ id : chr "abc"
.. ..$ :List of 2
.. .. ..$ message: chr "humbug"
.. .. ..$ id : chr "jkl"
$ id: chr "123"
How can I remove all the elements with name id in all levels of the list? i.e. the expected output is
> str(x)
List of 2
$ a:List of 1
..$ from: chr "me"
$ b:List of 1
..$ comment:List of 2
.. ..$ :List of 1
.. .. ..$ message: chr "blabla"
.. ..$ :List of 1
.. .. ..$ message: chr "humbug"
Solutions using rlist package would be particularly welcome, but I'm happy with anything that works.
Recursion is also how I did it:
# recursive function to remove name from all levels of list
stripname <- function(x, name) {
thisdepth <- depth(x)
if (thisdepth == 0) {
return(x)
} else if (length(nameIndex <- which(names(x) == name))) {
x <- x[-nameIndex]
}
return(lapply(x, stripname, name))
}
# function to find depth of a list element
# see http://stackoverflow.com/questions/13432863/determine-level-of-nesting-in-r
depth <- function(this, thisdepth=0){
if (!is.list(this)) {
return(thisdepth)
} else{
return(max(unlist(lapply(this,depth,thisdepth=thisdepth+1))))
}
}
str(stripname(x, "id"))
## List of 2
## $ a:List of 1
## ..$ from: chr "me"
## $ b:List of 1
## ..$ comment:List of 2
## .. ..$ :List of 1
## .. ..$ :List of 1
## .. .. ..$ message: chr "blabla"
## .. .. ..$ message: chr "humbug"
Try a recursive function in the veins of
f <- function(i)
lapply(i, function(x)
if (is.list(x)) {
if(!is.null(names(x))) f(x[names(x)!="id"]) else f(x)
} else x
)
str(f(x[names(x)!="id"]))
# List of 2
# $ a:List of 1
# ..$ from: chr "me"
# $ b:List of 1
# ..$ comment:List of 2
# .. ..$ :List of 1
# .. .. ..$ message: chr "blabla"
# .. ..$ :List of 1
# .. .. ..$ message: chr "humbug"
This is an old question, but this can also be done quite conveniently with rrapply() in the rrapply-package (revisit of base rapply()):
rrapply::rrapply(
x, ## nested list
condition = \(x, .xname) .xname != "id", ## filter condition
how = "prune" ## how to structure result
) |>
str()
#> List of 2
#> $ a:List of 1
#> ..$ from: chr "me"
#> $ b:List of 1
#> ..$ comment:List of 2
#> .. ..$ :List of 1
#> .. .. ..$ message: chr "blabla"
#> .. ..$ :List of 1
#> .. .. ..$ message: chr "humbug"

R: How to set names in a nested list from attributes

Edit: I rewrite this question, as I have two related questions that maybe could be answered better together...
I've got some large nested lists with nearly the same structure and without names. All items of the list have attributes and I want to assign these as names in all levels of the list. Furthermore I want to drop a needless list-level.
So this:
before <- list(list("value_1"), list(list("value_2a"), list("value_2b")), list(list("value_3a"), list("value_3b"), list("value_3c")), list("value_4"))
for(i in 1:4) attr(before[[i]], "tag") <- paste0("tag_", i)
attr(before[[2]][[1]], "code") <- "code_2a"
attr(before[[2]][[2]], "code") <- "code_2b"
attr(before[[3]][[1]], "code") <- "code_3a"
attr(before[[3]][[2]], "code") <- "code_3b"
attr(before[[3]][[3]], "code") <- "code_3c"
str(before)
## List of 4
## $ :List of 1
## ..$ : chr "value_1"
## ..- attr(*, "tag")= chr "tag_1"
## $ :List of 2
## ..$ :List of 1
## .. ..$ : chr "value_2a"
## .. ..- attr(*, "code")= chr "code_2a"
## ..$ :List of 1
## .. ..$ : chr "value_2b"
## .. ..- attr(*, "code")= chr "code_2b"
## ..- attr(*, "tag")= chr "tag_2"
## $ :List of 3
## ..$ :List of 1
## .. ..$ : chr "value_3a"
## .. ..- attr(*, "code")= chr "code_3a"
## ..$ :List of 1
## .. ..$ : chr "value_3b"
## .. ..- attr(*, "code")= chr "code_3b"
## ..$ :List of 1
## .. ..$ : chr "value_3c"
## .. ..- attr(*, "code")= chr "code_3c"
## ..- attr(*, "tag")= chr "tag_3"
## $ :List of 1
## ..$ : chr "value_4"
## ..- attr(*, "tag")= chr "tag_4"
(Note: 1st level list items have a "tag"-attribute, 2nd level items have a "code"-attribute.)
Should be this:
after <- list(tag_1="value_1", tag_2=list(code_2a="value_2a", code_2b="value_2b"), tag_3=list(code_3a="value_3a", code_3b="value_3b", code_3c="value_3c"), tag_4="value_4")
str(after)
## List of 4
## $ tag_1: chr "value_1"
## $ tag_2:List of 2
## ..$ code_2a: chr "value_2a"
## ..$ code_2b: chr "value_2b"
## $ tag_3:List of 3
## ..$ code_3a: chr "value_3a"
## ..$ code_3b: chr "value_3b"
## ..$ code_3c: chr "value_3c"
## $ tag_4: chr "value_4"
Since the lists are large, I want to avoid for loops, to get a better performance.
Got it! Three steps, but works perfectly.
# the ugly list
ugly_list <- list(list("value_1"), list(list("value_2a"), list("value_2b")), list(list("value_3a"), list("value_3b"), list("value_3c")), list("value_4"))
for(i in 1:4) attr(ugly_list[[i]], "tag") <- paste0("tag_", i)
attr(ugly_list[[2]][[1]], "code") <- "code_2a"
attr(ugly_list[[2]][[2]], "code") <- "code_2b"
attr(ugly_list[[3]][[1]], "code") <- "code_3a"
attr(ugly_list[[3]][[2]], "code") <- "code_3b"
attr(ugly_list[[3]][[3]], "code") <- "code_3c"
# set names for 1st level
level_1_named <- setNames(ugly_list, sapply(ugly_list, function(x) attributes(x)$tag))
# set names for 2nd level
level_2_named <- lapply(level_1_named, function(x) lapply(x, function(y) setNames(y, attributes(y)$code)))
# clean list
clean_list <- lapply(level_2_named, function(x) unlist(x, recursive=FALSE))
Thanks for trying. :-)
You can easily do this by recursing through the list. Try this:
setListNames <- function(mylist){
# Base case: if we have a nonlist object, set name to its attribute
if( !is.list(mylist) ){
names( mylist ) = attr(mylist, 'code')
return( mylist )
}
# lapply through all sublists and recursively call
mylist = lapply(mylist, setListNames)
# Return named list
return( mylist )
}
# Test run
before_named = setListNames(before)
# Check it worked
print( names( before_named[[2]][[1]][[1]] ) )

R: calculate the area within no closed contour lines

I want to calculate the area within a 0.975 contour lines, which some of them aren't closed. This is the plot:
contour(zpropMAteo, levels = c(0.975),lty = 1,drawlabels = F, col=2)
plot(contorno, add=T )
where contorno is a window: polygonal boundary, with the continuous border of the plot:
str(contorno)
#List of 5
# $ type : chr "polygonal"
# $ xrange: num [1:2] 704787 727062
# $ yrange: num [1:2] 4239419 4261570
# $ bdry :List of 1
# ..$ :List of 4
# .. ..$ x : num [1:9188] 704787 705760 705892 706135 706311 ...
# .. ..$ y : num [1:9188] 4251037 4248333 4247517 4247191 4246915 ...
# .. ..$ area: num 1.76e+08
# .. ..$ hole: logi FALSE
# $ units :List of 3
# ..$ singular : chr "unit"
# ..$ plural : chr "units"
# ..$ multiplier: num 1
# ..- attr(*, "class")= chr "units"
# - attr(*, "class")= chr "owin"
and zpropMAteo is a pixel image:
str(zpropMAteo)
#List of 10
# $ v : num [1:99, 1:100] NA NA NA NA NA NA NA NA NA NA ...
# ..- attr(*, "dimnames")=List of 2
# .. ..$ : chr [1:99] "4239530.43796768" "4239753.18885493" "4239975.93974217" "4240198.69062942" ...
# .. ..$ : chr [1:100] "704898.406701755" "705121.157589002" "705343.908476249" "705566.659363497" ...
# $ dim : int [1:2] 99 100
# $ xrange: num [1:2] 704787 727062
# $ yrange: num [1:2] 4239419 4261570
# $ xstep : num 223
# $ ystep : num 224
# $ xcol : num [1:100] 704898 705121 705344 705567 705789 ...
# $ yrow : num [1:99] 4239531 4239755 4239978 4240202 4240426 ...
# $ type : chr "real"
# $ units :List of 3
# ..$ singular : chr "unit"
# ..$ plural : chr "units"
# ..$ multiplier: num 1
# ..- attr(*, "class")= chr "units"
# - attr(*, "class")= chr "im"
The problem, as you can see in the plot(right), is that there are open contour lines. Maybe a solution can be calculate the intersection with contours lines and the border and then the area inside, or maybe first calculate a contour line which it be exactly the border, I don't know, contourline(100%) or something like that... and then to obtain the interseccion and the area inside.
I tried to do
clinessMAteo<-contourLines(zpropMAteo$xcol,zpropMAteo$yrow,zpropMAteo$v,levels = c(0.975))
with this result:
str(clinessMAteo)
#List of 7
# $ :List of 3
# ..$ level: num 0.975
# ..$ x : num [1:5] 710690 710584 710690 710716 710690
# ..$ y : num [1:5] 4246190 4246243 4246296 4246243 4246190
# $ :List of 3
# ..$ level: num 0.975
# ..$ x : num [1:19] 714031 713978 713978 714031 714066 ...
# ..$ y : num [1:19] 4245519 4245572 4245796 4245814 4245796 ...
# $ :List of 3
# ..$ level: num 0.975
# ..$ x : num [1:6] 715258 715258 715145 715136 715145 ...
# ..$ y : num [1:6] 4260226 4260339 4260510 4260563 4260581 ...
# $ :List of 3
# ..$ level: num 0.975
# ..$ x : num [1:38] 718932 719154 719377 719574 719600 ...
# ..$ y : num [1:38] 4256978 4256942 4256891 4256759 4256742 ...
# $ :List of 3
# ..$ level: num 0.975
# ..$ x : num [1:45] 719377 719600 719823 720045 720268 ...
# ..$ y : num [1:45] 4255696 4255691 4255710 4255710 4255687 ...
# $ :List of 3
# ..$ level: num 0.975
# ..$ x : num [1:42] 724959 724946 724723 724562 724500 ...
# ..$ y : num [1:42] 4253166 4253162 4253138 4252956 4252900 ...
# $ :List of 3
# ..$ level: num 0.975
# ..$ x : num [1:15] 722273 722238 722273 722496 722718 ...
# ..$ y : num [1:15] 4251802 4251837 4251858 4251920 4251848 ...
and the area:
areaMASteo <- sum(sapply(clinessMAteo,function(ring){areapl(cbind(ring$x,ring$y))
but I know it isn't correct because I think I should obtain contours lines closed first.
Any idea?? :-)

Resources