rlapply

Faster than R's `simplify2array`?

I often have code that looks like

rbind.oc.by <- function (indata, INDICES, FUN, ...) {
    result <- by( indata, INDICES, FUNIN, ... )
    t(simplify2array(result))
}

mynewdata <- rbind.oc.by( dataframe, dataframe$variable, function(dd) { with(dd, ... } )

So, I am testing it out:

set.seed(0)
if (!exists("X")) {
    X <- lapply( 1:10000000, function(i) {
        c(a=rnorm(1), b=rnorm(1), x="A", y= as.logical(rnorm(1)))
    })
}

## R CMD Rprof testprof.out                                                                                                         
Rprof("testprof.out")

intimealloc <- function() {
    as.data.frame(do.call("rbind", X))
}
v1 <- intimealloc()

firstalloc <- function() {
    simplify2array( t( X ))
}
v2 <- firstalloc()

Rprof(NULL)

simplify2array() is pretty good, about 8 times faster than do.call("rbind"). yet, I am still wondering whether there is a way to write a faster specialized version of simplify2array() that relies on the fact that results are either NULL or all the same data frame. presumably not, but I thought I would ask.

Solution

  • You could try unlist() |> array() |> t() to remove possible overhead (see lapply2 below) or or unlist() |> matrix(byrow=TRUE) to avoid transposing (see lapply3). However, instead of by() you could use split() |> lapply() |> simplify2array() |> t() or split() |> sapply() |> t(), since sapply() is like lapply() with integrated simplify2array(), or vapply():

    Benchmark

    $ Rscript --vanilla foo.R
Unit: milliseconds
    expr      min       lq     mean   median       uq      max neval cld
      by 759.6597 775.2684 833.4783 828.0770 854.1466 983.1176    10   a
  lapply 747.4017 753.7931 812.9594 824.6948 842.5910 893.2388    10   a
 lapply2 763.0132 769.7017 819.1545 811.0160 856.1791 904.2550    10   a
 lapply3 759.2881 777.8115 822.4855 826.9304 833.3351 945.4514    10   a
  sapply 764.3702 785.1906 805.3541 802.4946 821.7591 858.9353    10   a
  vapply 744.5296 746.5801 780.0658 767.1196 810.6612 840.4624    10   a

    enter image description here

    It just depends on what exactly you do in *apply() and whether the tradeoff is beneficial for writing custom code.

    Code

    set.seed(42)
mtcarsh <- mtcars[sample.int(nrow(mtcars), 1e6, replace=TRUE), ]
n <- length(unique(mtcarsh$am))
m <- ncol(mtcarsh)
microbenchmark::microbenchmark(
  by=by(mtcarsh, mtcarsh$am, colMeans) |> do.call(what='rbind'),
  lapply=split(mtcarsh, mtcarsh$am) |> lapply(colMeans) |> simplify2array() |> t(),
  lapply2=split(mtcarsh, mtcarsh$am) |> lapply(colMeans) |> unlist() |> 
    array(c(m, n), list(colnames(mtcarsh), unique(mtcarsh$am))) |> t(),
  lapply3=split(mtcarsh, mtcarsh$am) |> lapply(colMeans) |> unlist() |> 
    matrix(c(n, m), byrow=TRUE) |> `dimnames<-`(list(unique(mtcarsh$am), colnames(mtcarsh))),
  sapply=split(mtcarsh, mtcarsh$am) |> sapply(colMeans) |> t(),
  vapply=split(mtcarsh, mtcarsh$am) |> vapply(colMeans, FUN.VALUE=numeric(m)) |> t(),
  check='equal', times=10L
)