R/progress.R

In richfitz/queuer: Queue Tasks

##' Progress bar with timeout
##'
##' @title Progress bar with timeout
##'
##' @param total Total number of expected things.  Use `NULL` if
##'   you want to wait on a single thing
##'
##' @param timeout The number of seconds to wait
##'
##' @param ... Additional arguments to
##'   `progress::progress_bar$new`
##'
##' @param show Flag to indicate if the bar should be displayed.  If
##'   `NULL` then the global options `queuer.progress_show`
##'   and `queuer.progress_suppress` are used to determine if the
##'   bar is shown (with suppress overriding show).  This will
##'   evaluate to `TRUE` by default.  A logical flag overrides
##'   `queuer.progress_show` but not
##'   `queuer.progress_suppress`.
##'
##' @param label An optional label to prefix the timeout bar with
##'   (will not be padded with space), or in the case of `total =
##'   NULL` to indicate what is being waited on.
##'
##' @param digits The number of digits of accuracy to display the
##'   remaining time in
##'
##' @export
progress_timeout <- function(total, timeout, ..., show = NULL, label = NULL,
                             digits = 0) {
  show <- show_progress(show)
  if (show) {
    single <- is.null(total)
    if (single) {
      total <- 1L
    }
    forever <- !is.finite(timeout)
    width <- (if (digits > 0) digits + 1 else 0) +
      max(0, floor(log10(timeout))) + 1

    if (single) {
      if (is.null(label)) {
        label <- "task"
      }
      if (forever) {
        fmt <- sprintf("(:spin) waiting for %s, waited for :elapsed", label)
      } else {
        fmt <- sprintf("(:spin) waiting for %s, giving up in :remaining s",
                       label)
      }
    } else {
      if (forever) {
        fmt <- "(:spin) [:bar] :percent | waited for :elapsed"
      } else {
        fmt <- "(:spin) [:bar] :percent | giving up in :remaining s"
      }
      if (!is.null(label)) {
        fmt <- paste0(label, fmt)
      }
    }

    p <- progress::progress_bar$new(fmt, total = total, ...)$tick
    time_left <- time_checker(timeout, TRUE)

    function(len = 1, ..., clear = FALSE) {
      rem <- max(0, time_left())
      move <- if (clear || rem == 0) total else if (single) 0L else len
      if (forever) {
        p(move)
      } else {
        remaining <- formatC(rem, digits = digits, width = width, format = "f")
        p(move, tokens = list(remaining = remaining))
      }
      rem <= 0
    }
  } else {
    times_up <- time_checker(timeout, FALSE)
    function(..., clear = FALSE) {
      if (clear) 0 else times_up()
    }
  }
}

time_checker <- function(timeout, remaining = FALSE) {
  t0 <- Sys.time()
  timeout <- as.difftime(timeout, units = "secs")
  if (is.finite(timeout)) {
    if (remaining) {
      function() {
        as.double(timeout - (Sys.time() - t0), "secs")
      }
    } else {
      function() {
        Sys.time() - t0 > timeout
      }
    }
  } else {
    if (remaining) {
      function() Inf
    } else {
      function() FALSE
    }
  }
}

show_progress <- function(show) {
  !getOption("queuer.progress_suppress", FALSE) &&
    (show %||% getOption("queuer.progress_show", TRUE))
}