Function 使用进度条对循环进行包装

我喜欢在慢速运行

时使用进度条进行
循环。这可以通过几个助手轻松完成，但我确实喜欢Tcl-Tk包中的
tkProgressBar

一个小例子：

pb <- tkProgressBar(title = "Working hard:", min = 0, max = length(urls), width = 300)
for (i in 1:300) {
    # DO SOMETHING
    Sys.sleep(0.5)
    setTkProgressBar(pb, i, label=paste( round(i/length(urls)*100, 0), "% ready!"))
}
close(pb)

更新：我认为问题的核心是如何编写一个函数，该函数不仅在函数后面的括号中有参数（如：
foo（bar）
），而且可以处理在右括号后面指定的
expr
，如：
foo（bar）expr


赏金优惠：将转到任何可能修改的答案，使其与
循环的基本
语法类似。例如，代替

> forp(1:1000, {
+   a<-i
+ })
> a
[1] 1000

>forp（1:1000{
+a
[1] 1000

可以这样称呼：

> forp(1:1000) {
+   a<-i
+ }
> a
[1] 1000

forp（1:1000）{
+a
[1] 1000

再次澄清一下任务：我们如何获取函数调用的
{expression}
部分？我担心这是不可能的，但会给专业人士几天的奖金：）
如果您使用
plyr
命令系列而不是for循环（如果可能，通常是个好主意），您将获得整个进度条系统的额外奖励

R.utils
中还内置了一些进度条，并且存在进度条。
R的语法不允许您完全按照自己的意愿执行操作，即：

forp (i in 1:10) {
    #do something
}

但您可以使用while（）创建某种迭代器对象和循环：

现在您有了什么是
m
以及如何进行
nextStep（m）的问题
对
m
有副作用，以使其在循环结束时返回
FALSE
。我已经编写了简单的迭代器来实现这一点，以及MCMC迭代器，让您定义和测试循环中的老化和细化周期

最近在R用户会议上，我看到有人定义了一个“do”函数，然后作为操作员工作，比如：

do(100) %*% foo()

但我不确定那是确切的语法，我也不确定如何实现它或它是由谁提出的……也许其他人能记得！
我想你希望的是

body(for)<- as.call(c(as.name('{'),expression([your_updatebar], body(for))))

伪解析（c（“for（“，indexer，”）{，loopbody，”}”）
}

考虑到提供的其他答案，我怀疑要完全按照您指定的方式来做是不可能的

但是，如果你创造性地使用

plyr

包，我相信有一种方法可以非常接近。诀窍是使用

l\u ply

，它将列表作为输入，不创建输出

此解决方案与您的规范之间唯一的真正区别在于，在

for

循环中，您可以在相同的环境中直接修改变量。使用

l\u ply

您需要发送一个函数，因此，如果要修改父环境中的内容，您必须更加小心

请尝试以下操作：

library(plyr)
forp <- function(i, .fun){
  l_ply(i, .fun, .progress="tk")
}

a <- 0
forp(1:100, function(i){
  Sys.sleep(0.01)
  a<<-a+i
  })
print(a)
[1] 5050

库（plyr）
对于p我的解决方案与Andrie的非常相似，只是它使用了base R，我支持他的意见，即需要在函数中封装您想要做的事情，以及随后需要使用
感谢大家的友好回答！由于这些都不符合我古怪的需要，我开始偷取一些给定的答案，并制作了一个非常定制的解决方案标准化版本：

forp <- function(iis, .fun) {
    .fun <- paste(deparse(substitute(.fun)), collapse='\n')
    .fun <- gsub(' <- ', ' <<- ', .fun, fixed=TRUE)
    .fun <- paste(.fun, 'index.current <- 1 + index.current; setTkProgressBar(pb, index.current, label=paste( round(index.current/index.max*100, 0), "% ready!"))', sep='\n')
    ifelse(is.numeric(iis), index.max <- max(iis), index.max <- length(iis))
    index.current <- 1
    pb <- tkProgressBar(title = "Working hard:", min = 0, max = index.max, width = 300) 
    for (i in iis) eval(parse(text=paste(.fun)))
    close(pb)
}

尝试查看计算机上整洁的进度条！：）

示例#2:循环遍历某些字符

> m <- 0
> forp (names(mtcars), {
+   m <- m + mean(mtcars[,i])
+ })
> m
[1] 435.69

>m代表（名称（mtcars）{
+m m
[1] 435.69
问题是R中的for循环被特殊处理。正常函数不允许这样。一些小的调整可以使它的循环非常接近。正如@Aaron所提到的，foreach包的
%dopar%
范例似乎是最合适的。下面是我对其工作原理的解释：

`%doprogress%` <- function(forExpr, bodyExpr) {
   forExpr <- substitute(forExpr)
   bodyExpr <- substitute(bodyExpr)

   idxName <- names(forExpr)[[2]]
   vals <- eval(forExpr[[2]])

   e <- new.env(parent=parent.frame())

   pb <- tkProgressBar(title = "Working hard:", min = 0, max = length(vals), width = 300)
   for (i in seq_along(vals)) {
     e[[idxName]] <- vals[[i]]
     eval(bodyExpr, e)
     setTkProgressBar(pb, i, label=paste( round(i/length(vals)*100, 0), "% ready!"))
   }
}


# Example usage:

foreach(x = runif(10)) %doprogress% { 
  # do something
  if (x < 0.5) cat("small\n") else cat("big")
}

`%doprogress%`我在此提出两个使用标准
语法的解决方案，这两个解决方案都使用了Gábor Csárdi和Rich FitzJohn的伟大软件包


1） 我们可以临时或本地覆盖
for
函数，以环绕
base:：for
并支持进度条
2） 我们可以为（它在seq）{exp}
中定义未使用的
，其中
pb
是使用
progress:：progress\u bar$new（）
构建的进度条

这两种解决方案都作为呼叫的标准：


在上一次迭代中更改的值可用
错误时，修改的变量将具有错误发生前的值

我打包了我的解决方案，并将在下面演示它们，然后将完成代码


用法
使用
pb\u for（）
默认情况下，
pb_for（）
将覆盖
for
功能，只运行一次

pb_for()
for (i in 1:10) {
  # DO SOMETHING
  Sys.sleep(0.5)
}

使用
progress:：progress\u bar$new（）
中的参数：

pb_for(format = "Working hard: [:bar] :percent :elapsed", 
       callback = function(x) message("Were'd done!"))
for (i in 1:10) {
  # DO SOMETHING
  Sys.sleep(0.5)
}

为后一个示例使用
看起来与foreach软件包中的
foreach
语法类似。也谢谢@Spacedman！我现在不确定您的建议如何帮助我编写
forp
函数，但我会努力赶上：）将报告。感谢您的回答：
plyr
在大多数情况下都是一个非常好的工具当然，但我有时肯定需要
进行
循环（使用复杂的结构，其中数据分布在多个数据集中）.不幸的是，链接的资源只显示了一个我在问题中输入的示例，因此只有几种手动方式将进度条添加到
for
循环中，但不知道我想要的是什么自动进度条（例如
forp
功能）。这看起来确实是我的伪代码答案的一个不错的版本。但是：如果要运行一个包含多个变量的现有函数，会发生什么呢？
lply（i，myfunc（x，y））
就我所知是行不通的。@CarlWitthoft这没关系，不是吗？因为for循环中只能有一个变量。其他变量都只是引用而已
x <- LETTERS[1:5]
for(xi in x) myfun(xi, "hi")
forp(x, myfun, text="hi")

out <- "result:"
for(xi in x) {
  out <- paste(out, myfun(xi, "hi"))
}

out <- "result:"
forp(x, function(xi) {
    out <<- paste(out, myfun(xi, "hi"))
})

> out
[1] "result: A B C D E"

forp2 <- function(index, x, expr) {
  expr <- substitute(expr)
  n <- length(x)
  pb <- tkProgressBar(title = "Working hard:", min = 0, max = n, width = 300)
  for (i in seq_len(n)) {
    assign(index, x[i], envir=parent.frame())
    eval(expr, envir=parent.frame())
    setTkProgressBar(pb, i, label=paste( round(i/n*100, 0), "% ready!"))
  }
  close(pb)
}

out <- "result:"
forp2("xi", LETTERS[1:5], {
    out <- paste(out, myfun(xi, "hi"))
})

`%doX%` <- function(index, expr) {
  x <- index[[1]]
  index <- names(index)
  expr <- substitute(expr)
  n <- length(x)
  pb <- tkProgressBar(title = "Working hard:", min = 0, max = n, width = 300)
  for (i in seq_len(n)) {
    assign(index, x[i], envir=parent.frame())
    eval(expr, envir=parent.frame())
    setTkProgressBar(pb, i, label=paste( round(i/n*100, 0), "% ready!"))
  }
  close(pb)
  invisible(out)
}

forX <- function(...) {
  a <- list(...)
  if(length(a)!=1) {
    stop("index must have only one element")
  }
  a
}

out <- "result:"
forX(xi=LETTERS[1:5]) %doX% {
  out <- paste(out, myfun(xi, "hi"))
}
out

forp <- function(iis, .fun) {
    .fun <- paste(deparse(substitute(.fun)), collapse='\n')
    .fun <- gsub(' <- ', ' <<- ', .fun, fixed=TRUE)
    .fun <- paste(.fun, 'index.current <- 1 + index.current; setTkProgressBar(pb, index.current, label=paste( round(index.current/index.max*100, 0), "% ready!"))', sep='\n')
    ifelse(is.numeric(iis), index.max <- max(iis), index.max <- length(iis))
    index.current <- 1
    pb <- tkProgressBar(title = "Working hard:", min = 0, max = index.max, width = 300) 
    for (i in iis) eval(parse(text=paste(.fun)))
    close(pb)
}

> forp(1:1000, {
+   a<-i
+ })
> a
[1] 1000

> m <- 0
> forp (names(mtcars), {
+   m <- m + mean(mtcars[,i])
+ })
> m
[1] 435.69

`%doprogress%` <- function(forExpr, bodyExpr) {
   forExpr <- substitute(forExpr)
   bodyExpr <- substitute(bodyExpr)

   idxName <- names(forExpr)[[2]]
   vals <- eval(forExpr[[2]])

   e <- new.env(parent=parent.frame())

   pb <- tkProgressBar(title = "Working hard:", min = 0, max = length(vals), width = 300)
   for (i in seq_along(vals)) {
     e[[idxName]] <- vals[[i]]
     eval(bodyExpr, e)
     setTkProgressBar(pb, i, label=paste( round(i/length(vals)*100, 0), "% ready!"))
   }
}


# Example usage:

foreach(x = runif(10)) %doprogress% { 
  # do something
  if (x < 0.5) cat("small\n") else cat("big")
}

#devtools::install_github("moodymudskipper/pbfor")
library(pbfor)

pb_for()
for (i in 1:10) {
  # DO SOMETHING
  Sys.sleep(0.5)
}

pb_for(format = "Working hard: [:bar] :percent :elapsed", 
       callback = function(x) message("Were'd done!"))
for (i in 1:10) {
  # DO SOMETHING
  Sys.sleep(0.5)
}

i <- NA 
progress_bar$new() -> for (i in 1:10) {
  # DO SOMETHING
  Sys.sleep(0.5)
}

pb <- progress_bar$new(format = "Working hard: [:bar] :percent :elapsed", 
       callback = function(x) ("Were'd done!"))
pb  -> for (i in 1:10) {
  # DO SOMETHING
  Sys.sleep(0.5)
}

pbi <- progress_bar$new(format = "i: [:bar] :percent\n\n")
pbj <- progress_bar$new(format = "j: [:bar] :percent  ")
i <- NA
j <- NA
pbi  -> for (i in 1:10) {
  pbj  -> for (j in 1:10) {
    # DO SOMETHING
    Sys.sleep(0.1)
  }
}

pb_for <-
  function(
    # all args of progress::progress_bar$new() except `total` which needs to be
    # infered from the 2nd argument of the `for` call, and `stream` which is
    # deprecated
    format = "[:bar] :percent",
    width = options("width")[[1]] - 2,
    complete = "=",
    incomplete = "-",
    current =">",
    callback = invisible, # doc doesn't give default but this seems to work ok
    clear = TRUE,
    show_after = .2,
    force = FALSE,
    # The only arg not forwarded to progress::progress_bar$new()
    # By default `for` will self detruct after being called
    once = TRUE) {

    # create the function that will replace `for`
    f <- function(it, seq, expr){
      # to avoid notes at CMD check
      `*pb*` <- IT <- SEQ <- EXPR <- NULL

      # forward all arguments to progress::progress_bar$new() and add
      # a `total` argument computed from `seq` argument
      pb <- progress::progress_bar$new(
        format = format, width = width, complete = complete,
        incomplete = incomplete, current = current,
        callback = callback,
        clear = clear, show_after = show_after, force = force,
        total = length(seq))

      # using on.exit allows us to self destruct `for` if relevant even if
      # the call fails.
      # It also allows us to send to the local environment the changed/created
      # variables in their last state, even if the call fails (like standard for)
      on.exit({
        vars <- setdiff(ls(env), c("*pb*"))
        list2env(mget(vars,envir = env), envir = parent.frame())
        if(once) rm(`for`,envir = parent.frame())
      })

      # we build a regular `for` loop call with an updated loop code including
      # progress bar.
      # it is executed in a dedicated environment and the progress bar is given
      # a name unlikely to conflict
      env <- new.env(parent = parent.frame())
      env$`*pb*` <-  pb
      eval(substitute(
        env = list(IT = substitute(it), SEQ = substitute(seq), EXPR = substitute(expr)),
        base::`for`(IT, SEQ,{
          EXPR
          `*pb*`$tick()
        })), envir = env)
    }
    # override `for` in the parent frame
    assign("for", value = f,envir = parent.frame())
  }

`for<-` <-
  function(it, seq, expr, value){
    # to avoid notes at CMD check
    `*pb*` <- IT <- SEQ <- EXPR <- NULL
    # the symbol fed to `it` is unknown, R uses `*tmp*` for assignment functions
    # so we go get it by inspecting the memory addresses
    it_chr <- fetch_name(it)
    it_sym <-as.symbol(it_chr)

    #  complete the progress bar with the `total` parameter
    # we need to clone it because progress bars are environments and updated
    # by reference
    pb <- value$clone()
    pb$.__enclos_env__$private$total <- length(seq)

    # when the script ends, even with a bug, the values that have been changed
    # are written to the parent frame
    on.exit({
      vars <- setdiff(ls(env), c("*pb*"))
      list2env(mget(vars, env),envir = parent.frame())
    })

    # computations are operated in a separate environment so we don't pollute it
    # with it, seq, expr, value, we need the progress bar so we name it `*pb*`
    # unlikely to conflict by accident
    env <- new.env(parent = parent.frame())
    env$`*pb*` <-  pb
    eval(substitute(
      env =  list(IT = it_sym, SEQ = substitute(seq), EXPR = substitute(expr)),
      base::`for`(IT, SEQ,{
        EXPR
        `*pb*`$tick()
      })), envir = env)

    # because of the `fun<-` syntax we need to return the modified first argument
    invisible(get(it_chr,envir = env))
  }

fetch_name <- function(x,env = parent.frame(2)) {
  all_addresses       <- sapply(ls(env), address2, env)
  all_addresses       <- all_addresses[names(all_addresses) != "*tmp*"]
  all_addresses_short <- gsub("(^|<)[0x]*(.*?)(>|$)","\\2",all_addresses)

  x_address       <- tracemem(x)
  untracemem(x)
  x_address_short <- tolower(gsub("(^|<)[0x]*(.*?)(>|$)","\\2",x_address))

  ind    <- match(x_address_short, all_addresses_short)
  x_name <- names(all_addresses)[ind]
  x_name
}

address2 <- getFromNamespace("address2", "pryr")