关于 r：如何监控应用功能的进度？


How to monitor progress of an apply function?

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

  • 估计应用功能完成所需的时间
  • 监控其进度
  • 能够暂停并在以后继续

    • 这里是代码：

    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    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看起来像这样：

    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    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")]
    所以也许整个过程可以更有效地完成，谁知道呢。

    相关讨论

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

    就您的问题而言：

    1
    2
    3
    4
    library(pbapply)      
    library(data.table)      

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

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

    相关讨论

    您可以使用 utils 包中的 txtProgressBar：

    1
    2
    3
    4
    5
    6
    7
    total <- 50
    pb <- txtProgressBar(min = 0, max = total, style = 3)

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

    或使用 plyr 包

    中的 *ply 系列

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

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

    试试这个：

    1
    2
    3
    4
    setkey(SOURCE, NAME)

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

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

    相关讨论

    对于花哨的进度条(不在基础/标准库中)，还有 progress:

    1
    2
    3
    4
    5
    6
    7
    8
    9
    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 用于更一般的对象序列化

    我希望这会有所帮助。

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

    我在解决这个问题时学到了一些非常有用的东西。我最初计划依靠 terminfo 进行光标控制。具体来说，我打算使用 tput:

    预先计算当前终端的代码以向左移动光标

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

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

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

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

    开头的名称简单地转储到全局环境中

    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    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('\
    ');
        cat(msg);
        cat('\
    ');
        progI <<- progI+1L;
    }; ## end prog()
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    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 对象上运行代码时，估计的行为不正常；首先它迅速下降，然后稳步上升。这似乎是由于处理速度变慢造成的，我无法解释，我不确定你是否看到同样的事情。在任何情况下，理论上，如果您等待循环接近完成，估计剩余时间的增加应该会逆转，最终估计应该在计算完成时下降到零。但是尽管有这个怪癖，但我非常确信代码是正确的，因为它可以按预期运行更快(即计算量更少)的测试用例。

    您是否要进行交叉连接？请参阅此示例：

    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    #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)