I have a question on the way how to speedup certain things in R. The code example is following:
n=1000
A=matrix(rnorm(n), 1, n)
T=diag(n)
Rprof()
for (i in 1:100)
A = apply(T, 1, function(row) max(A*row)) + matrix(rnorm(n), 1,n)
Rprof(NULL)
summaryRprof()
Profile is following:
> $by.self
self.time self.pct total.time total.pct
"apply" 2.16 37.50 5.74 99.65
"*" 2.06 35.76 2.06 35.76
"aperm.default" 1.08 18.75 1.08 18.75
"max" 0.42 7.29 0.42 7.29
"FUN" 0.02 0.35 2.50 43.40
"rnorm" 0.02 0.35 0.02 0.35
As you can see the slowest thing is function apply. Could you suggest a way to get rid of this function to speedup the whole computation?
Generally you're better off with lists than matrices. In your specific case:
set.seed(1) # for reproducibility
n=1000
A=matrix(rnorm(n), 1, n)
T=diag(n)
set.seed(1) # for reproducibility
system.time({
for (i in 1:100)
X = apply(T, 1, function(row) max(A*row)) + matrix(rnorm(n), 1,n)
})
# user system elapsed
# 5.83 0.13 5.98
df <- as.data.frame(t(T))
set.seed(1) # for reproducibility
system.time({
for (i in 1:100)
Y = sapply(df, function(row) max(A*row)) + matrix(rnorm(n), 1,n)
})
# user system elapsed
# 0.97 0.00 0.96
identical(X,Y)
# [1] TRUE
Related
I have the following function to reorder letters in a character vector.
reorder_letter <- function(x){
sapply(strsplit(x,split = ""),function(x) paste(sort(toupper(x)),collapse = ""))
}
reorder_letter(c("trErty","Bca","def"))
#> [1] "ERRTTY" "ABC" "DEF"
Created on 2020-04-29 by the reprex package (v0.3.0)
Basically I want to return same letter of the character but with upper case and sorted order.
Currently it takes around 1 min to run for a 1.5 million length vector.
EDIT: I also tried to parallelize using future.apply package which is 3x faster than base R solution (also easy to modify current code)
reorder_letter <- function(x){
future_sapply(strsplit(x,split = ""),function(x) paste(sort(toupper(x)),collapse = ""))
}
I just wonder
how can I efficiently achieve my purpose?
what is the best approach to find the bottleneck of a function? For example, I have this function finished. What the next step?
Maybe utf8ToInt and intToUtf8 are faster than strsplit and paste.
x <- c("trErty","Bca","def")
unlist(lapply(x, function(y) {intToUtf8(sort(utf8ToInt(toupper(y))))}))
#[1] "ERRTTY" "ABC" "DEF"
Times: (It is not faster ... sorry)
But stringi is faster and writing a Function C++ is even more faster (and might be improved but it's already 10 times faster).
FrankZhang <- function(x) {
unlist(lapply(strsplit(toupper(x),NULL),function(x) paste(sort(x),collapse = "")))}
GKi <- function(x) {
unlist(lapply(toupper(x), function(y) {intToUtf8(sort(utf8ToInt(y)))}))
}
library(stringi)
stringi <- function(y) {
vapply(stri_split_boundaries(toupper(y), type = "character"), function(x) stri_c(x[stri_order(x)], collapse = ""), "")
}
library(Rcpp)
cppFunction("std::string GKiC(std::string &str) {
std::sort(str.begin(), str.end());
return(str);}")
GKi2 <- function(x) {unlist(lapply(toupper(x), GKiC))}
x <- apply(expand.grid(letters, LETTERS), 1, paste, collapse = "")
microbenchmark::microbenchmark(FrankZhang(x), GKi(x), stringi(x), GKi2(x), control=list(order="block"))
#Unit: milliseconds
# expr min lq mean median uq max neval cld
# FrankZhang(x) 17.533428 18.686879 20.380002 19.719311 21.014381 33.836692 100 d
# GKi(x) 16.551358 17.665436 18.656223 18.271688 19.343088 23.225199 100 c
# stringi(x) 4.644196 4.844622 5.082298 5.011344 5.237714 7.355251 100 b
# GKi2(x) 1.527124 1.624337 1.997725 1.691099 2.242797 5.593543 100 a
To find out what uses much computation time you can use Rprof e.g.:
reorder_letter <- function(x) { #Function
sapply(strsplit(x,split = ""),function(x) paste(sort(toupper(x)),collapse = ""))}
x <- apply(expand.grid(letters, LETTERS, letters), 1, paste, collapse = "") #Data
Rprof()
y <- reorder_letter(x)
Rprof(NULL)
summaryRprof()
#$by.self
# self.time self.pct total.time total.pct
#"FUN" 0.12 20.69 0.54 93.10
#"sort.int" 0.10 17.24 0.22 37.93
#"paste" 0.08 13.79 0.42 72.41
#"sort" 0.06 10.34 0.34 58.62
#"sort.default" 0.06 10.34 0.28 48.28
#"match.arg" 0.04 6.90 0.10 17.24
#"eval" 0.04 6.90 0.04 6.90
#"sapply" 0.02 3.45 0.58 100.00
#"lapply" 0.02 3.45 0.56 96.55
#".doSortWrap" 0.02 3.45 0.02 3.45
#"formals" 0.02 3.45 0.02 3.45
#
#$by.total
# total.time total.pct self.time self.pct
#"sapply" 0.58 100.00 0.02 3.45
#"reorder_letter" 0.58 100.00 0.00 0.00
#"lapply" 0.56 96.55 0.02 3.45
#"FUN" 0.54 93.10 0.12 20.69
#"paste" 0.42 72.41 0.08 13.79
#"sort" 0.34 58.62 0.06 10.34
#"sort.default" 0.28 48.28 0.06 10.34
#"sort.int" 0.22 37.93 0.10 17.24
#"match.arg" 0.10 17.24 0.04 6.90
#"eval" 0.04 6.90 0.04 6.90
#".doSortWrap" 0.02 3.45 0.02 3.45
#"formals" 0.02 3.45 0.02 3.45
#
#$sample.interval
#[1] 0.02
#
#$sampling.time
#[1] 0.58
I need to get the results of the following function
getScore <- function(history, similarities) {
nh<-ifelse(similarities<0, 6-history,history)
x <- nh*abs(similarities)
contados <- !is.na(history)
x2 <- sum(x, na.rm=TRUE)/sum(abs(similarities[contados]),na.rm=TRUE)
x2
}
For example for the following vectors:
notes <- c(1:5, NA)
history <- sample(notes, 1000000, replace=T)
similarities <- runif(1000000, -1,1)
That changes inside a loop. This takes:
ptm <- proc.time()
for (i in (1:10)) getScore(history, similarities)
proc.time() - ptm
user system elapsed
3.71 1.11 4.67
Initially I suspect that the problem is the for loop, but profiling result points to ifelse().
Rprof("foo.out")
for (i in (1:10)) getScore(history, similarities)
Rprof(NULL)
summaryRprof("foo.out")
$by.self
self.time self.pct total.time total.pct
"ifelse" 2.96 65.78 3.48 77.33
"-" 0.24 5.33 0.24 5.33
"getScore" 0.22 4.89 4.50 100.00
"<" 0.22 4.89 0.22 4.89
"*" 0.22 4.89 0.22 4.89
"abs" 0.22 4.89 0.22 4.89
"sum" 0.22 4.89 0.22 4.89
"is.na" 0.12 2.67 0.12 2.67
"!" 0.08 1.78 0.08 1.78
$by.total
total.time total.pct self.time self.pct
"getScore" 4.50 100.00 0.22 4.89
"ifelse" 3.48 77.33 2.96 65.78
"-" 0.24 5.33 0.24 5.33
"<" 0.22 4.89 0.22 4.89
"*" 0.22 4.89 0.22 4.89
"abs" 0.22 4.89 0.22 4.89
"sum" 0.22 4.89 0.22 4.89
"is.na" 0.12 2.67 0.12 2.67
"!" 0.08 1.78 0.08 1.78
$sample.interval
[1] 0.02
$sampling.time
[1] 4.5
ifelse() is my performance bottleneck. Unless there is a way in R to speed up ifelse(), there is unlikely to be great performance boost.
However, ifelse() is already the vectorized approach. It seems to me that the only chance left is to use C/C++. But is there a way to avoid using compiled code?
You can use logical multiplication for this task to achieve the same effect:
s <- similarities < 0
nh <- s*(6-history) + (!s)*history
Benchmark on i7-3740QM:
f1 <- function(history, similarities) { s <- similarities < 0
s*(6-history) + (!s)*history}
f2 <- function(history, similarities) ifelse(similarities<0, 6-history,history)
f3 <- function(history, similarities) { nh <- history
ind <- similarities<0
nh[ind] <- 6 - nh[ind]
nh }
microbenchmark(f1(history, similarities),
f2(history, similarities),
f3(history, similarities))
## Unit: milliseconds
## expr min lq mean median uq max neval cld
## f1(history, similarities) 22.830260 24.6167695 28.31384860 24.89869950000000 25.651655 81.043713 100 a
## f2(history, similarities) 364.514460 412.7117810 408.37156626 415.10114899999996 417.345748 437.977256 100 c
## f3(history, similarities) 84.220279 86.2894795 92.64614571 87.18016549999999 89.616522 149.243051 100 b
On E5-2680 v2:
## Unit: milliseconds
## expr min lq mean median uq max neval cld
## f1(history, similarities) 20.03963 20.10954 21.41055 20.68597 21.25920 50.95278 100 a
## f2(history, similarities) 314.54913 315.96621 324.91486 319.50290 325.93168 378.26016 100 c
## f3(history, similarities) 73.81413 73.92162 76.10418 74.79893 75.84634 105.98770 100 b
On T5600 (Core2 Duo Mobile):
## Unit: milliseconds
expr min lq mean median uq max neval cld
## f1(history, similarities) 147.2953 152.9307 171.0870 155.5632 167.0998 344.7524 100 b
## f2(history, similarities) 408.5728 493.3886 517.0573 501.6993 525.8573 797.9624 100 c
## f3(history, similarities) 102.9621 110.6003 131.1826 112.9961 125.3906 303.1170 100 a
Aha! My approach is slower on the Core 2 architecture.
I have encountered this before. We don't have to use ifelse() all the time. If you have a look at how ifelse is written, by typing "ifelse" in your R console, you can see that this function is written in R language, and it does various checking which is really inefficient.
Instead of using ifelse(), we can do this:
getScore <- function(history, similarities) {
######## old code #######
# nh <- ifelse(similarities < 0, 6 - history, history)
######## old code #######
######## new code #######
nh <- history
ind <- similarities < 0
nh[ind] <- 6 - nh[ind]
######## new code #######
x <- nh * abs(similarities)
contados <- !is.na(history)
sum(x, na.rm=TRUE) / sum(abs(similarities[contados]), na.rm = TRUE)
}
And then let's check profiling result again:
Rprof("foo.out")
for (i in (1:10)) getScore(history, similarities)
Rprof(NULL)
summaryRprof("foo.out")
# $by.total
# total.time total.pct self.time self.pct
# "getScore" 2.10 100.00 0.88 41.90
# "abs" 0.32 15.24 0.32 15.24
# "*" 0.26 12.38 0.26 12.38
# "sum" 0.26 12.38 0.26 12.38
# "<" 0.14 6.67 0.14 6.67
# "-" 0.14 6.67 0.14 6.67
# "!" 0.06 2.86 0.06 2.86
# "is.na" 0.04 1.90 0.04 1.90
# $sample.interval
# [1] 0.02
# $sampling.time
# [1] 2.1
We have a 2+ times boost in performance. Furthermore, the profile is more like a flat profile, without any single part dominating execution time.
In R, vector indexing / reading / writing is at speed of C code, so whenever we can, use a vector.
Testing #Matthew's answer
mat_getScore <- function(history, similarities) {
######## old code #######
# nh <- ifelse(similarities < 0, 6 - history, history)
######## old code #######
######## new code #######
ind <- similarities < 0
nh <- ind*(6-history) + (!ind)*history
######## new code #######
x <- nh * abs(similarities)
contados <- !is.na(history)
sum(x, na.rm=TRUE) / sum(abs(similarities[contados]), na.rm = TRUE)
}
Rprof("foo.out")
for (i in (1:10)) mat_getScore(history, similarities)
Rprof(NULL)
summaryRprof("foo.out")
# $by.total
# total.time total.pct self.time self.pct
# "mat_getScore" 2.60 100.00 0.24 9.23
# "*" 0.76 29.23 0.76 29.23
# "!" 0.40 15.38 0.40 15.38
# "-" 0.34 13.08 0.34 13.08
# "+" 0.26 10.00 0.26 10.00
# "abs" 0.20 7.69 0.20 7.69
# "sum" 0.18 6.92 0.18 6.92
# "<" 0.16 6.15 0.16 6.15
# "is.na" 0.06 2.31 0.06 2.31
# $sample.interval
# [1] 0.02
# $sampling.time
# [1] 2.6
Ah? Slower?
The full profiling result shows that this approach spends more time on floating point multiplication "*", and the logical not "!" seems pretty expensive. While my approach requires floating point addition / subtraction only.
Well, The result might be also architecture dependent. I am testing on Intel Nahalem (Intel Core 2 Duo) at the moment. So benchmarking between two approaches on various platforms are welcomed.
Remark
All profiling are using OP's data in the question.
Here is a faster ifelse, though it isn't faster than the above answers, it maintains the ifelse structure.
ifelse_sign <- function(b,x,y){
x[!b] <- 0
y[b] <-0
x + y + b *0
}
For pedagogical purposes I am trying to compare the memory use profiles of two simple functions. However, I am hitting a problem which I am wondering is a bug in either Rprof() or summayRprof. Does a anyone have any ideas what I am doing wrong or how I can work around this problem?
fun.rbind <- function(indata) {
outdata <- NULL
n <- nrow(indata)
for (i in 1:n) {
if (!any(is.na(indata[i,]))) outdata <- rbind(outdata, indata[i,])
}
outdata
}
And,
fun.omit <- function(indata) {
drop <- FALSE
n = ncol(indata)
for (i in 1:n) drop <- drop | is.na(indata[, i])
indata[!drop, ]
}
Where the second version should be much more efficient in terms of both execution time and memory use.
If I do the following, it works just fine.
> data.matrix <- matrix(rnorm(2000000), 100000, 20)
> data.matrix[data.matrix > 2] <- NA
> Rprof("fun.omit.out", memory.profiling = TRUE)
> y <- fun.omit(data.matrix)
> Rprof(NULL)
> summaryRprof("fun.omit.out", memory="both")
$by.self
self.time self.pct total.time total.pct mem.total
"fun.omit" 0.04 50 0.08 100 38.5
"|" 0.04 50 0.04 50 22.5
$by.total
total.time total.pct mem.total self.time self.pct
"fun.omit" 0.08 100 38.5 0.04 50
"|" 0.04 50 22.5 0.04 50
$sample.interval
[1] 0.02
$sampling.time
[1] 0.08
However, the same operation on the fist function fails with a cryptic error message.
> Rprof("fun.rbind.out", memory.profiling = TRUE)
> y <- fun.rbind(data.matrix)
> Rprof(NULL)
> summaryRprof("fun.rbind.out", memory = "both")
Error in rowsum.default(memcounts[rep.int(seq_along(memcounts), ulen)], :
unimplemented type 'NULL' in 'HashTableSetup'
In addition: Warning message:
In is.na(x) : is.na() applied to non-(list or vector) of type 'NULL'
If I don't use the memory = 'both' options, everything works as expected.
> summaryRprof("fun.rbind.out")
$by.self
self.time self.pct total.time total.pct
"rbind" 312.62 99.64 312.62 99.64
"fun.rbind" 0.84 0.27 313.74 100.00
"any" 0.12 0.04 0.12 0.04
"!" 0.08 0.03 0.08 0.03
"is.na" 0.08 0.03 0.08 0.03
$by.total
total.time total.pct self.time self.pct
"fun.rbind" 313.74 100.00 0.84 0.27
"rbind" 312.62 99.64 312.62 99.64
"any" 0.12 0.04 0.12 0.04
"!" 0.08 0.03 0.08 0.03
"is.na" 0.08 0.03 0.08 0.03
$sample.interval
[1] 0.02
$sampling.time
[1] 313.74
If anyone is interested I think I have determined that the source of my problem is a bug in summaryRprof(). If I use memory = "stats" or memory = "timeseries" options I get the expected results every time. Apparently the memory = "both" option does not always work.
For example the following works as I would expect.
> gctorture(on = TRUE)
> Rprof("fun.rbind.out", memory.profiling = TRUE)
> y <- fun.rbind(data.matrix)
> Rprof(NULL)
> gctorture(on = FALSE)
> summaryRprof("fun.rbind.out", memory = "stats")
index: "fun.rbind"
vsize.small max.vsize.small vsize.large max.vsize.large
188 173856 19658 8962426
nodes max.nodes duplications tot.duplications
16630 15977360 1 860
samples
1009
---------------------------------------------------------------
index: "fun.rbind":"!"
vsize.small max.vsize.small vsize.large max.vsize.large
17 17 16660 16660
nodes max.nodes duplications tot.duplications
1456 1456 1 1
samples
1
---------------------------------------------------------------
index: "fun.rbind":"any"
vsize.small max.vsize.small vsize.large max.vsize.large
22 82 9383 67880
nodes max.nodes duplications tot.duplications
796 2688 1 896
samples
741
---------------------------------------------------------------
index: "fun.rbind":"is.na"
vsize.small max.vsize.small vsize.large max.vsize.large
18 51 9561 34040
nodes max.nodes duplications tot.duplications
958 2520 1 51
samples
91
---------------------------------------------------------------
index: "fun.rbind":"rbind"
vsize.small max.vsize.small vsize.large max.vsize.large
8 51 5966 68440
nodes max.nodes duplications tot.duplications
777 2800 1 948
samples
1215
While it is a bit of a extra work to have to summarize the profiles of execution time and memory use in two steps, I can live with this.
Foremost, I am looking for a fast(er) way of subsetting/indexing a matrix many, many times over:
for (i in 1:99000) {
subset.data <- data[index[, i], ]
}
Background:
I'm implementing a sequential testing procedure involving the bootstrap in R. Wanting to replicate some simulation results, I came upon
this bottleneck where lots of indexing needs to be done. For implementation of the block-bootstrap I created an index matrix with which I subset
the original data matrix to draw resamples of the data.
# The basic setup
B <- 1000 # no. of bootstrap replications
n <- 250 # no. of observations
m <- 100 # no. of models/data series
# Create index matrix with B columns and n rows.
# Each column represents a resampling of the data.
# (actually block resamples, but doesn't matter here).
boot.index <- matrix(sample(1:n, n * B, replace=T), nrow=n, ncol=B)
# Make matrix with m data series of length n.
sample.data <- matrix(rnorm(n * m), nrow=n, ncol=m)
subsetMatrix <- function(data, index) { # fn definition for timing
subset.data <- data[index, ]
return(subset.data)
}
# check how long it takes.
Rprof("subsetMatrix.out")
for (i in 1:(m - 1)) {
for (b in 1:B) { # B * (m - 1) = 1000 * 99 = 99000
boot.data <- subsetMatrix(sample.data, boot.index[, b])
# do some other stuff
}
# do some more stuff
}
Rprof()
summaryRprof("subsetMatrix.out")
# > summaryRprof("subsetMatrix.out")
# $by.self
# self.time self.pct total.time total.pct
# subsetMatrix 9.96 100 9.96 100
# In the actual application:
#########
# > summaryRprof("seq_testing.out")
# $by.self
# self.time self.pct total.time total.pct
# subsetMatrix 6.78 53.98 6.78 53.98
# colMeans 1.98 15.76 2.20 17.52
# makeIndex 1.08 8.60 2.12 16.88
# makeStats 0.66 5.25 9.66 76.91
# runif 0.60 4.78 0.72 5.73
# apply 0.30 2.39 0.42 3.34
# is.data.frame 0.22 1.75 0.22 1.75
# ceiling 0.18 1.43 0.18 1.43
# aperm.default 0.14 1.11 0.14 1.11
# array 0.12 0.96 0.12 0.96
# estimateMCS 0.10 0.80 12.56 100.00
# as.vector 0.10 0.80 0.10 0.80
# matrix 0.08 0.64 0.08 0.64
# lapply 0.06 0.48 0.06 0.48
# / 0.04 0.32 0.04 0.32
# : 0.04 0.32 0.04 0.32
# rowSums 0.04 0.32 0.04 0.32
# - 0.02 0.16 0.02 0.16
# > 0.02 0.16 0.02 0.16
#
# $by.total
# total.time total.pct self.time self.pct
# estimateMCS 12.56 100.00 0.10 0.80
# makeStats 9.66 76.91 0.66 5.25
# subsetMatrix 6.78 53.98 6.78 53.98
# colMeans 2.20 17.52 1.98 15.76
# makeIndex 2.12 16.88 1.08 8.60
# runif 0.72 5.73 0.60 4.78
# doTest 0.68 5.41 0.00 0.00
# apply 0.42 3.34 0.30 2.39
# aperm 0.26 2.07 0.00 0.00
# is.data.frame 0.22 1.75 0.22 1.75
# sweep 0.20 1.59 0.00 0.00
# ceiling 0.18 1.43 0.18 1.43
# aperm.default 0.14 1.11 0.14 1.11
# array 0.12 0.96 0.12 0.96
# as.vector 0.10 0.80 0.10 0.80
# matrix 0.08 0.64 0.08 0.64
# lapply 0.06 0.48 0.06 0.48
# unlist 0.06 0.48 0.00 0.00
# / 0.04 0.32 0.04 0.32
# : 0.04 0.32 0.04 0.32
# rowSums 0.04 0.32 0.04 0.32
# - 0.02 0.16 0.02 0.16
# > 0.02 0.16 0.02 0.16
# mean 0.02 0.16 0.00 0.00
#
# $sample.interval
# [1] 0.02
#
# $sampling.time
# [1] 12.56'
Doing the sequential testing procedure once takes about 10 seconds. Using this in simulations with 2500 replications and several
parameter constellations, it would take something like 40 days. Using parallel processing and better CPU power it's possible to do faster, but
still not very pleasing :/
Is there a better way to resample the data / get rid of the loop?
Can apply, Vectorize, replicate etc. come in anywhere?
Would it make sense to implement the subsetting in C (e.g. manipulate some pointers)?
Even though every single step is already done incredibly fast by R, it's just not quite fast enough.
I'd be very glad indeed for any kind of response/help/advice!
related Qs:
- Fast matrix subsetting via '[': by rows, by columns or doesn't matter?
- fast function for generating bootstrap samples in matrix forms in R
- random sampling - matrix
from there
mapply(function(row) return(sample.data[row,]), row = boot.index)
replicate(B, apply(sample.data, 2, sample, replace = TRUE))
didn't really do it for me.
I rewrote makeStats and makeIndex as they were two of the biggest bottlenecks:
makeStats <- function(data, index) {
data.mean <- colMeans(data)
m <- nrow(data)
n <- ncol(index)
tabs <- lapply(1L:n, function(j)tabulate(index[, j], nbins = m))
weights <- matrix(unlist(tabs), m, n) * (1 / nrow(index))
boot.data.mean <- t(data) %*% weights - data.mean
return(list(data.mean = data.mean,
boot.data.mean = boot.data.mean))
}
makeIndex <- function(B, blocks){
n <- ncol(blocks)
l <- nrow(blocks)
z <- ceiling(n/l)
start.points <- sample.int(n, z * B, replace = TRUE)
index <- blocks[, start.points]
keep <- c(rep(TRUE, n), rep(FALSE, z*l - n))
boot.index <- matrix(as.vector(index)[keep],
nrow = n, ncol = B)
return(boot.index)
}
This brought down the computation times from 28 to 6 seconds on my machine. I bet there are other parts of the code that can be improved (including my use of lapply/tabulate above.)
I have a large data frame with a factor column that I need to divide into three factor columns by splitting up the factor names by a delimiter. Here is my current approach, which is very slow with a large data frame (sometimes several million rows):
data <- readRDS("data.rds")
data.df <- reshape2:::melt.array(data)
head(data.df)
## Time Location Class Replicate Population
##1 1 1 LIDE.1.S 1 0.03859605
##2 2 1 LIDE.1.S 1 0.03852957
##3 3 1 LIDE.1.S 1 0.03846853
##4 4 1 LIDE.1.S 1 0.03841260
##5 5 1 LIDE.1.S 1 0.03836147
##6 6 1 LIDE.1.S 1 0.03831485
Rprof("str.out")
cl <- which(names(data.df)=="Class")
Classes <- do.call(rbind, strsplit(as.character(data.df$Class), "\\."))
colnames(Classes) <- c("Species", "SizeClass", "Infected")
data.df <- cbind(data.df[,1:(cl-1)],Classes,data.df[(cl+1):(ncol(data.df))])
Rprof(NULL)
head(data.df)
## Time Location Species SizeClass Infected Replicate Population
##1 1 1 LIDE 1 S 1 0.03859605
##2 2 1 LIDE 1 S 1 0.03852957
##3 3 1 LIDE 1 S 1 0.03846853
##4 4 1 LIDE 1 S 1 0.03841260
##5 5 1 LIDE 1 S 1 0.03836147
##6 6 1 LIDE 1 S 1 0.03831485
summaryRprof("str.out")
$by.self
self.time self.pct total.time total.pct
"strsplit" 1.34 50.00 1.34 50.00
"<Anonymous>" 1.16 43.28 1.16 43.28
"do.call" 0.04 1.49 2.54 94.78
"unique.default" 0.04 1.49 0.04 1.49
"data.frame" 0.02 0.75 0.12 4.48
"is.factor" 0.02 0.75 0.02 0.75
"match" 0.02 0.75 0.02 0.75
"structure" 0.02 0.75 0.02 0.75
"unlist" 0.02 0.75 0.02 0.75
$by.total
total.time total.pct self.time self.pct
"do.call" 2.54 94.78 0.04 1.49
"strsplit" 1.34 50.00 1.34 50.00
"<Anonymous>" 1.16 43.28 1.16 43.28
"cbind" 0.14 5.22 0.00 0.00
"data.frame" 0.12 4.48 0.02 0.75
"as.data.frame.matrix" 0.08 2.99 0.00 0.00
"as.data.frame" 0.08 2.99 0.00 0.00
"as.factor" 0.08 2.99 0.00 0.00
"factor" 0.06 2.24 0.00 0.00
"unique.default" 0.04 1.49 0.04 1.49
"unique" 0.04 1.49 0.00 0.00
"is.factor" 0.02 0.75 0.02 0.75
"match" 0.02 0.75 0.02 0.75
"structure" 0.02 0.75 0.02 0.75
"unlist" 0.02 0.75 0.02 0.75
"[.data.frame" 0.02 0.75 0.00 0.00
"[" 0.02 0.75 0.00 0.00
$sample.interval
[1] 0.02
$sampling.time
[1] 2.68
Is there any way to speed up this operation? I note that there are a small (<5) number of each of the categories "Species", "SizeClass", and "Infected", and I know what these are in advance.
Notes:
stringr::str_split_fixed performs this task, but not any faster
The data frame is actually initially generated by calling reshape::melt on an array in which Class and its associated levels are a dimension. If there's a faster way to get from there to here, great.
data.rds at http://dl.getdropbox.com/u/3356641/data.rds
This should probably offer quite an increase:
library(data.table)
DT <- data.table(data.df)
DT[, c("Species", "SizeClass", "Infected")
:= as.list(strsplit(Class, "\\.")[[1]]), by=Class ]
The reasons for the increase:
data.table pre allocates memory for columns
every column assignment in data.frame reassigns the entirety of the data (data.table in contrast does not)
the by statement allows you to implement the strsplit task once per each unique value.
Here is a nice quick method for the whole process.
# Save the new col names as a character vector
newCols <- c("Species", "SizeClass", "Infected")
# split the string, then convert the new cols to columns
DT[, c(newCols) := as.list(strsplit(as.character(Class), "\\.")[[1]]), by=Class ]
DT[, c(newCols) := lapply(.SD, factor), .SDcols=newCols]
# remove the old column. This is instantaneous.
DT[, Class := NULL]
## Have a look:
DT[, lapply(.SD, class)]
# Time Location Replicate Population Species SizeClass Infected
# 1: integer integer integer numeric factor factor factor
DT
You could get a decent increase in speed by just extracting the parts of the string you need using gsub instead of splitting everything up and trying to put it back together:
data <- readRDS("~/Downloads/data.rds")
data.df <- reshape2:::melt.array(data)
# using `strsplit`
system.time({
cl <- which(names(data.df)=="Class")
Classes <- do.call(rbind, strsplit(as.character(data.df$Class), "\\."))
colnames(Classes) <- c("Species", "SizeClass", "Infected")
data.df <- cbind(data.df[,1:(cl-1)],Classes,data.df[(cl+1):(ncol(data.df))])
})
user system elapsed
3.349 0.062 3.411
#using `gsub`
system.time({
data.df$Class <- as.character(data.df$Class)
data.df$SizeClass <- gsub("(\\w+)\\.(\\d+)\\.(\\w+)", "\\2", data.df$Class,
perl = TRUE)
data.df$Infected <- gsub("(\\w+)\\.(\\d+)\\.(\\w+)", "\\3", data.df$Class,
perl = TRUE)
data.df$Class <- gsub("(\\w+)\\.(\\d+)\\.(\\w+)", "\\1", data.df$Class,
perl = TRUE)
})
user system elapsed
0.812 0.037 0.848
Looks like you have a factor, so work on the levels and then map back. Use fixed=TRUE in strsplit, adjusting to split=".".
Classes <- do.call(rbind, strsplit(levels(data.df$Class), ".", fixed=TRUE))
colnames(Classes) <- c("Species", "SizeClass", "Infected")
df0 <- as.data.frame(Classes[data.df$Class,], row.names=NA)
cbind(data.df, df0)