Speedproblems by using apply in a function to translate multiple strings - r

Question

I wrote a little function dictTranslator to translate multiple strings into abbreviations or group them into categories... I use a list as a dictionary and have a data frame column with abbreviations and I want a column category with the related category name.
dictTranslator <- function(x, dict) {
sapply(x, function(a) {
result <- names(which(sapply(dict, function(b) {a %in% b})))
if(identical(result, character(0))) {
warning(sprintf('NAs are introduced, "%s" not found!', a), call.=FALSE)
NA
} else {
result
}
})
}
my_dictionary <-
list(embryo=c('00h','01h','02h','e02','03h','04h','05h','06h','e06',
'08h','10h','12h','e12','14h','16h','18h','20h','e20'),
larvae=c('L1','L2','L3e','L3l'),
pupae=c('p1','p2','p3','p4','p5'),
adult=c('vm','m','vf','f'))
sample data:
df <- data.frame(abbreviation=rep(unlist(my_dictionary), 30000))
nrow(df)
# [1] 930000
system.time(df$category <- dictTranslator(df$abbreviation, my_dictionary))
The function works as expected but the performance is pretty slow (about a minute). Has anyone an idea to speed this up or is there maybe a better solution to this?
The result looks like:
> head(df,40)
abbreviation category
1 00h embryo
2 01h embryo
...
19 L1 larvae
20 L2 larvae
21 L3e larvae
22 L3l larvae
23 p1 pupae
24 p2 pupae
25 p3 pupae
26 p4 pupae
27 p5 pupae
28 vm adult
29 m adult
30 vf adult
31 f adult
32 00h embryo
33 01h embryo
34 02h embryo
35 e02 embryo
36 03h embryo

Answer 1

I would use match on a named vector, plus removal of the numbers generated by unlisting my_dictionary (for which I used sub). This way you can avoid costly loops.
x <- unlist(my_dictionary)
df$category <- sub('\\d+$', '', names(x)[match(df$abbreviation, x)])
Run time is less than a second:
df <- data.frame(abbreviation=rep(unlist(my_dictionary), 30000),
stringsAsFactors = FALSE)
system.time({df$category <- sub('\\d+$', '', names(x)[match(df$abbreviation, x)])})
# User System elapsed
# 0.634 0.003 0.639

Answer 2

I found this approach finished fastest on my machine. Note that the input data is character which results in speed gains when compared with factor input.
## non-factor sample data
my_dictionary <- unlist(my_dictionary)
df <- data.frame(abbreviation = rep(my_dictionary, 30000),
stringsAsFactors = FALSE)
system.time({
## names
result <- sapply(df$abbreviation, function(i) {
names(which(i == my_dictionary))
})
## discard numbers
df$category <- gsub("\\d", "", result)
})
# user system elapsed
# 3.993 0.000 3.991
As regards the code you provided (i.e., using multiple sapply loops in combination with %in%), keep in mind that %in% (or match) perform rather poorly when you are searching for a single entry (see e.g. this question).

Answer 3

I suggest another data format for dictionary, also use data.table library:
library(data.table)
md <- list()
for(i in 1:length(my_dictionary)) {
md[[i]] <- data.table(abbreviation = my_dictionary[[i]], category = names(my_dictionary[i]))
}
md <- rbindlist(md)
Then you simply join:
df <- data.table(df, key = 'abbreviation')
df <- df[md]
Comparison. I did ran a comparison of three approaches and here are the results:
Data preparation:
#docendo-discimus and #fdetsch use same data format
md1 <- unlist(my_dictionary)
df1 <- df
#danas.zuokas uses
library(data.table)
md2 <- list()
for(i in 1:length(my_dictionary)) {
md2[[i]] <- data.table(abbreviation = my_dictionary[[i]], category = names(my_dictionary[i]))
}
md2 <- rbindlist(md2)
df2 <- data.table(df, key = 'abbreviation')
Here are three functions to compare
f_dd <- function(x, y) { x$category <- sub('\\d+$', '', names(y)[match(x$abbreviation, y)]); x } #docendo-discimus
f_dz <- function(x, y) { x <- x[y]; x } #danas.zuokas
f_fd <- function(x, y) { x$category <- gsub('\\d', '', sapply(x$abbreviation, function(i) names(which(i == y)))); x } #fdetsch
And here are the results
library(microbenchmark)
microbenchmark(f_dd(df1, md1), f_fd(df1, md1), f_dz(df2, md2), times = 10)
Unit: milliseconds
expr min lq mean median uq max neval
f_dd(df1, md1) 1041.9195 1142.8361 1236.2033 1224.498 1266.9600 1469.7119 10
f_fd(df1, md1) 7106.6641 7417.5538 7924.3541 7868.716 8304.7760 8961.2615 10
f_dz(df2, md2) 35.6389 41.7524 77.2347 63.478 70.1699 183.9867 10

Answer 4

I will use a named vector for this:
a2c <- c ("larvae", "larvae", "larvae", "pupae", "pupae", ...)
names (a2e) <- c ('L1','L2','L3e','p1', 'p2', ...)
In your case you can easily build the vector doing:
a2c <- rep (names (my_dictionary), times = sapply (my_dictionary, length))
names (a2c) <- unlist (my_dictionary)
Make sure they match:
cbind (names (a2c), a2c)
And then:
df[,"category"] <- a2c[df$abbreviation]
In your example df$abbreviation is a factor so you may need to turn it into character
df[,"category"] <- a2c[as.character (df$abbreviation)]