如何监控应用功能的进度？答案

【问题标题】：How to monitor progress of an apply function?如何监控应用功能的进度？
【发布时间】：2016-09-21 09:03:35
【问题描述】：

我需要计算出一个 2886*2886 的相关矩阵，问题是构建中间数据表 (RESULT) 需要很长时间才能将其绑定在一起，所以我希望能够在执行以下操作的同时在下面的代码中调用最后一行RESULT=rbindlist(apply(COMB, 1, append))：

估计完成应用函数所需的时间
监控其进度
以后可以暂停并继续

代码如下：

SOURCE=data.table(NAME=rep(paste0("NAME", as.character(1:2889)), each=600), VALUE=sample(c(TRUE,FALSE), 600, TRUE) )
> SOURCE
            NAME VALUE
      1:   NAME1  TRUE
      2:   NAME1  TRUE
      3:   NAME1  TRUE
      4:   NAME1  TRUE
      5:   NAME1  TRUE
     ---              
1733396: NAME999  TRUE
1733397: NAME999  TRUE
1733398: NAME999  TRUE
1733399: NAME999  TRUE
1733400: NAME999 FALSE

setkey(SOURCE,NAME)
a=SOURCE[,unique(NAME)]
COMB=data.table(expand.grid(a,a, stringsAsFactors=FALSE))
> COMB
             Var1    Var2
      1:    NAME1   NAME1
      2:   NAME10   NAME1
      3:  NAME100   NAME1
      4: NAME1000   NAME1
      5: NAME1001   NAME1
     ---                 
8346317:  NAME995 NAME999
8346318:  NAME996 NAME999
8346319:  NAME997 NAME999
8346320:  NAME998 NAME999
8346321:  NAME999 NAME999

append <- function(X) {
data.table(NAME1=X[1], VALUE1=SOURCE[X[1], VALUE], 
    NAME2=X[2], VALUE2=SOURCE[X[2], VALUE] )
}

RESULT=rbindlist(apply(COMB, 1, append))

有什么想法吗？

您还知道是否有更快的方法从SOURCE 生成数据表RESULT？ RESULT 是一个中间数据表，用于计算每对 NAME 的 VALUE1 和 VALUE2 之间的相关值。

SOURCE 的子集RESULT看起来像这样：

SOURCE=SOURCE[sample(1:nrow(SOURCE), 3)]
setkey(SOURCE,NAME)
a=SOURCE[,unique(NAME)]
COMB=data.table(expand.grid(a,a, stringsAsFactors=FALSE))
RESULT=rbindlist(apply(COMB, 1, append))
> RESULT
      NAME1 VALUE1    NAME2 VALUE2
1: NAME1859   TRUE NAME1859   TRUE
2:  NAME768  FALSE NAME1859   TRUE
3:  NAME795   TRUE NAME1859   TRUE
4: NAME1859   TRUE  NAME768  FALSE
5:  NAME768  FALSE  NAME768  FALSE
6:  NAME795   TRUE  NAME768  FALSE
7: NAME1859   TRUE  NAME795   TRUE
8:  NAME768  FALSE  NAME795   TRUE
9:  NAME795   TRUE  NAME795   TRUE

稍后我将执行RESULT[,VALUE3:=(VALUE1==VALUE2)] 以最终获得相关值：RESULT[, mean(VALUE3), by=c("NAME1", "NAME2")] 所以也许整个过程可以更有效地完成，谁知道呢。

【问题讨论】：

为了进步，我经常在函数的开头添加一行，例如lapply(1:nrow(f), function(i){print(i/nrow(f)# your function})

标签： r data.table apply

【解决方案1】：

您可以使用库 pbapply(git)，它显示了 '*apply' 系列中任何函数的时间估计和进度条。

就您的问题而言：

library(pbapply)      
library(data.table)      

result <- data.table::rbindlist( pbapply(COMB, 1, append) )

ps。这个答案解决了你的两个初始点。关于第三点，我不确定是否可以暂停该功能。无论如何，您的操作确实花费了太长时间，因此我建议您单独发布一个问题，询问如何优化您的任务。

【讨论】：

它说它不适用于 R 版本 3.0.3
他们应该尽快更新软件包。同时，您可以使用 R 版本 3.2.5
Warning in install.packages : package ‘‘pbapply’ is not available (for R version 3.2.5) 也试过 3.3.0
试试library(devtools) ; install_github("psolymos/pbapply")。如果还是不行，您可以在github page 报告错误。
仅供参考：pbapply 现在可在 CRAN 上使用。

【解决方案2】：

对于花哨的进度条（不在基本/标准库中），还有progress：

pb <- progress_bar$new(
  format = "  downloading [:bar] :percent eta: :eta",
  total = 100, clear = FALSE, width= 60)
for (i in 1:100) {
  pb$tick()
  Sys.sleep(1 / 100)
}

#> downloading [========----------------------]  28% eta:  1s

所以这满足了要求 (1) 和 (2)，而不是 (3)。对于缓存中间结果，不时将内容写入磁盘可能是最简单的。对于快速序列化，您可以尝试

fst：方便序列化data.tables等列式数据结构
qs 用于更通用的对象序列化

我希望这会有所帮助。

【讨论】：

【解决方案3】：

您可以使用utils 包中的txtProgressBar：

total <- 50
pb <- txtProgressBar(min = 0, max = total, style = 3)

lapply(1:total, function(i){
Sys.sleep(0.1)
setTxtProgressBar(pb, i)
})

或使用plyr 包中的*ply 家庭

library(plyr)
laply(1:100, function(i) {Sys.sleep(0.05); i}, .progress = "text")

查看?create_progress_bar()了解更多详情

【讨论】：

【解决方案4】：

试试这个：

setkey(SOURCE, NAME)

SOURCE[, CJ(NAME, NAME, unique = T)][
       , mean(SOURCE[V1, VALUE] == SOURCE[V2, VALUE]), by = .(V1, V2)]

Fwiw，全大写的名字在 imo 中是一个糟糕的选择 - 使编写和阅读代码变得更加困难。

【讨论】：

感谢您提供了更好的方法，但有没有办法监控其进度？
@ChiseledAbs 我只是插入一个打印语句（可能有一些频率）；例如以上：..., {print(paste(V1, V2)); mean(SOURCE[... )}, by = .(V1, V2)]
当我尝试你的代码时，我得到Error in bmerge(i <- shallow(i), x, leftcols, rightcols, io <- haskey(i), : typeof x.VALUE (logical) != typeof i.V1 (character)
@ChiseledAbs 的答案有误 - 再试一次

【解决方案5】：

我刚刚编写了自己的文本进度线实现。我不知道txtProgressBar()，所以感谢@JavK！但我仍然会在这里分享我的实现。

我在解决这个问题时学到了一些非常有用的东西。我最初计划依靠terminfo 进行光标控制。具体来说，我打算使用 tput 预先计算当前终端的代码以将光标向左移动：

tc_left <- system2('tput','cub1',stdout=T);

然后我将重复打印该代码以在每次更新后将光标重置到进度行的开头。此解决方案有效，但仅适用于安装了正确 terminfo 数据库的 Unix 终端；它不适用于其他平台，尤其是 Windows 上的 RStudio。

然后，当我查看txtProgressBar() 代码时（在阅读了@JavK 的答案后），我发现他们使用了一种更简单、更强大的解决方案来重置光标位置：他们只是打印一个回车！它就像cat('\r'); 一样简单，这就是我现在在我的实现中使用的。

这是我的解决方案。它涉及一个名为progInit() 的初始化函数，您必须在计算密集型循环之前调用一次，并且必须将循环的迭代总数传递给该函数（因此您必须提前知道），以及一个名为prog() 增加循环计数器并更新进度线。状态变量只是以prog 开头的名称转储到全局环境中。

progInit <- function(N,dec=3L) {
    progStart <<- Sys.time();
    progI <<- 1L;
    progN <<- N;
    progDec <<- dec;
}; ## end progInit()

prog <- function() {
    rem <- unclass(difftime(Sys.time(),progStart,units='secs'))*(progN/progI-1);
    days <- as.integer(rem/86400); rem <- rem-days*86400;
    hours <- as.integer(rem/3600); rem <- rem-hours*3600;
    minutes <- as.integer(rem/60); rem <- rem-minutes*60;
    seconds <- as.integer(rem); rem <- rem-seconds;
    millis <- as.integer(rem*1000);
    over <- paste(collapse='',rep(' ',20L));
    pct <- progI/progN*100;
    if (days!=0L) {
        msg <- sprintf(' %.*f%% %dd/%02d:%02d:%02d.%03d%s',
            progDec,pct,days,hours,minutes,seconds,millis,over);
    } else {
        msg <- sprintf(' %.*f%% %02d:%02d:%02d.%03d%s',
            progDec,pct,hours,minutes,seconds,millis,over);
    }; ## end if
    cat('\r');
    cat(msg);
    cat('\r');
    progI <<- progI+1L;
}; ## end prog()

library(data.table);
SOURCE <- data.table(NAME=rep(paste0("NAME", as.character(1:2889)), each=600), VALUE=sample(c(TRUE,FALSE), 600, TRUE) );
setkey(SOURCE,NAME);
a <- SOURCE[,unique(NAME)];
COMB <- data.table(expand.grid(a,a, stringsAsFactors=FALSE));
append <- function(X) {
    prog();
    data.table(NAME1=X[1],VALUE1=SOURCE[X[1],VALUE],NAME2=X[2],VALUE2=SOURCE[X[2],VALUE]);
}; ## end append()
##x <- COMB; progInit(nrow(x)); rbindlist(apply(x,1,append)); ## full object
x <- COMB[1:1e4,]; progInit(nrow(x)); rbindlist(apply(x,1,append)); ## ~30s

我使用一个简单的算法来估计剩余时间：我基本上将总经过时间除以到目前为止完成的迭代次数（得到时间/迭代），然后将其乘以剩余迭代次数。

不幸的是，当我在您的完整 COMB 对象上运行代码时，估计的行为不正常；首先它迅速下降，然后稳步上升。这似乎是由于处理速度变慢造成的，我无法解释，我不确定你是否看到同样的事情。在任何情况下，理论上，如果您等待循环接近完成，估计剩余时间的增加应该会逆转，最终估计应该在计算完成时下降到零。但是尽管有这个怪癖，但我非常确信代码是正确的，因为它在更快（即计算密集度较低）的测试用例中按预期工作。

【讨论】：

【解决方案6】：

您是否要进行交叉连接？看这个例子：

#dummy data
set.seed(1)
SOURCE = data.frame(
  NAME = sample(paste0("Name", 1:4),20, replace = TRUE),
  VALUE = sample(c(TRUE,FALSE), 20, replace = TRUE)
)

#update colnames for join
d1 <- SOURCE
colnames(d1) <- c("NAME1", "VALUE1")
d2 <- SOURCE
colnames(d2) <- c("NAME2", "VALUE2")

#cross join
merge(d1, d2, all = TRUE)

【讨论】：