Question

作为包summarise_posterior（available here）的一部分，我有一个很棒的小功能driver（如下所示）。

该功能很棒，而且超级有用。一个问题是我一直在处理越来越大的数据，而且速度可能非常慢。简而言之，我的问题是：是否有一种提速的方式来加快此速度，同时仍保留该功能的关键灵活性（请参见文档中的示例）。

至少要弄清楚一个键调用中的位数计算方法，而不是一遍又一遍地调用分位数函数，至少可以提高一次按键的速度。当前实现的后一种选择可能是一遍又一遍地重新排序相同的向量。

#' Shortcut for summarize variable with quantiles and mean
#'
#' @param data tidy data frame
#' @param var variable name (unquoted) to be summarised
#' @param ... other expressions to pass to summarise
#'
#' @return data.frame
#' @export
#' @details Notation: \code{pX} refers to the \code{X}\% quantile
#' @import dplyr
#' @importFrom stats quantile
#' @importFrom rlang quos quo UQ
#' @examples
#' d <- data.frame("a"=sample(1:10, 50, TRUE),
#'                 "b"=rnorm(50))
#'
#' # Summarize posterior for b over grouping of a and also calcuate
#' # minmum of b (in addition to normal statistics returned)
#' d <- dplyr::group_by(d, a)
#' summarise_posterior(d, b, mean.b = mean(b), min=min(b))
summarise_posterior <- function(data, var, ...){
  qvar <- enquo(var)
  qs <- quos(...)


  data %>%
    summarise(p2.5 = quantile(!!qvar, prob=0.025),
              p25 = quantile(!!qvar, prob=0.25),
              p50 = quantile(!!qvar, prob=0.5),
              mean = mean(!!qvar),
              p75 = quantile(!!qvar, prob=0.75),
              p97.5 = quantile(!!qvar, prob=0.975),
              !!!qs)
}

Rcpp后端选项也非常受欢迎。

谢谢！

Answer 1

这是一个利用嵌套来避免多次调用quantile的解决方案。每当您需要将结果向量存储在summarize中时，只需将其包装在list中即可。之后，您可以取消嵌套这些结果，将它们与它们的名称配对，然后使用spread将它们放在单独的列中：

summarise_posterior2 <- function(data, var, ...){
  qvar <- ensym(var)
  vq <- c(0.025, 0.25, 0.5, 0.75, 0.975)

  summarise( data, .qq = list(quantile(!!qvar, vq, names=FALSE)),
             .nms = list(str_c("p", vq*100)), mean = mean(!!qvar), ... ) %>%
  unnest %>% spread( .nms, .qq )  
}

这与@ jay.sf的解决方案几乎没有相同的速度

d <- data.frame("a"=sample(1:10, 5e5, TRUE), "b"=rnorm(5e5))    
microbenchmark::microbenchmark( f1 = summarise_posterior(d, b, mean.b = mean(b), min=min(b)),
                                f2 = summarise_posterior2(d, b, mean.b = mean(b), min=min(b)) )
# Unit: milliseconds
#  expr      min       lq     mean   median       uq      max neval
#    f1 49.06697 50.81422 60.75100 52.43030 54.17242 200.2961   100
#    f2 29.05209 29.66022 32.32508 30.84492 32.56364 138.9579   100

，但是它可以与group_by并在嵌套函数（whereas substitute-based solutions will break when nested)中使用。

r1 <- d %>% dplyr::group_by(a) %>% summarise_posterior(b, mean.b = mean(b), min=min(b))
r2 <- d %>% dplyr::group_by(a) %>% summarise_posterior2(b, mean.b = mean(b), min=min(b))
all_equal( r1, r2 )     # TRUE

如果您分析代码，则可以看到主要的挂断电话所在

Rprof()
for( i in 1:100 )
  d %>% dplyr::group_by(a) %>% summarise_posterior2(b, mean.b = mean(b), min=min(b))
Rprof(NULL)
summaryRprof()$by.self %>% head
#             self.time self.pct total.time total.pct
# ".Call"          1.84    49.73       3.18     85.95
# "sort.int"       0.94    25.41       1.12     30.27
# "eval"           0.08     2.16       3.64     98.38
# "tryCatch"       0.08     2.16       1.44     38.92
# "anyNA"          0.08     2.16       0.08      2.16
# "structure"      0.04     1.08       0.08      2.16

.Call主要对应于dplyr的C ++后端，而sort.int是quantile()之后的工作者。 @ jay.sf的解决方案通过与dplyr解耦获得了很大的加速，但同时也失去了相关的灵活性（例如，与group_by的集成）。最终，由您决定哪个更重要。

Answer 2

为什么不这样？

summarise_posterior2 <- function(data, x, ...){
  x <- deparse(substitute(x))
  nm <- deparse(substitute(...))
  M <- matrix(unlist(data[, x]), ncol=length(data[, x]))
  qs <- t(sapply(list(...), do.call, list(M)))
  'rownames<-'(cbind(p2.5 = quantile(M, prob=0.025),
        p25 = quantile(M, prob=0.25),
        p50 = quantile(M, prob=0.5),
        mean = mean(M),
        p75 = quantile(M, prob=0.75),
        p97.5 = quantile(M, prob=0.975), qs), NULL
  )
}

> summarise_posterior2(df1, X4, mean=mean, mean=mean, min=min)
     p2.5 p25 p50 mean p75 p97.5 mean mean min
[1,] 28.2  30  32   32  34  35.8   32   32  28

# > summarise_posterior(df1, X4, mean.b = mean(X4), min=min(X4))
#   p2.5 p25 p50 mean p75 p97.5 mean.b min
# 1 28.2  30  32   32  34  35.8     32  28

运行速度快六倍：

> microbenchmark::microbenchmark(orig.fun=summarise_posterior(df1, X4, max(X4), min(X4)),
+                                new.fun=summarise_posterior2(df1, X4, max=max, min=min))
Unit: microseconds
     expr      min       lq      mean   median       uq      max neval
 orig.fun 4289.541 4324.490 4514.1634 4362.500 4411.225 8928.316   100
  new.fun  716.071  734.694  802.9949  755.867  778.317 4759.439   100

数据

df1 <- data.frame(matrix(1:144, 9, 16))

加快多个分位数的Tidyverse计算

2 个答案: