From 12b00ff1896bd18a0070610ab930704c16a8b213 Mon Sep 17 00:00:00 2001 From: Mitchell Date: Mon, 11 Mar 2019 10:29:58 +1100 Subject: [PATCH] Added progress bar for model() Resolves https://github.com/tidyverts/fable/issues/121 --- R/model.R | 8 ++- R/progress.R | 155 +++++++++++++++++++++++++++++++++++++++++++++++++++ R/zzz.R | 7 +++ 3 files changed, 169 insertions(+), 1 deletion(-) create mode 100644 R/progress.R diff --git a/R/model.R b/R/model.R index 39431a36..292967c2 100644 --- a/R/model.R +++ b/R/model.R @@ -12,13 +12,19 @@ model <- function(.data, ...){ model.tbl_ts <- function(.data, ...){ nm <- map(enexprs(...), expr_text) models <- dots_list(...) + pb <- progress_estimated(length(models) * n_keys(.data)) keys <- key(.data) .data <- nest(group_by(.data, !!!keys), .key = "lst_data") + eval_models <- function(models, lst_data){ map(models, function(model){ - map(lst_data, estimate, model) + map(lst_data, function(dt, mdl){ + out <- estimate(dt, mdl) + pb$tick()$print() + out + }, model) }) } diff --git a/R/progress.R b/R/progress.R new file mode 100644 index 00000000..cc10f82c --- /dev/null +++ b/R/progress.R @@ -0,0 +1,155 @@ +#' Progress bar with estimated time. +#' +#' Adapted from dplyr to suit the purpose of modelling. +#' This reference class represents a text progress bar displayed estimated +#' time remaining. When finished, it displays the total duration. The +#' automatic progress bar can be disabled by setting option +#' `fable.show_progress` to `FALSE`. +#' +#' @param n Total number of items +#' @param min_time Progress bar will wait until at least `min_time` +#' seconds have elapsed before displaying any results. +#' @return A ref class with methods `tick()`, `print()`, +#' `pause()`, and `stop()`. +#' @keywords internal +#' @export +#' @examples +#' p <- progress_estimated(3) +#' p$tick() +#' p$tick() +#' p$tick() +#' +#' p <- progress_estimated(3) +#' for (i in 1:3) p$pause(0.1)$tick()$print() +#' +#' p <- progress_estimated(3) +#' p$tick()$print()$ +#' pause(1)$stop() +#' +#' # If min_time is set, progress bar not shown until that many +#' # seconds have elapsed +#' p <- progress_estimated(3, min_time = 3) +#' for (i in 1:3) p$pause(0.1)$tick()$print() +#' +#' \dontrun{ +#' p <- progress_estimated(10, min_time = 3) +#' for (i in 1:10) p$pause(0.5)$tick()$print() +#' } +progress_estimated <- function(n, min_time = 0) { + Progress$new(n, min_time = min_time) +} + +#' @importFrom R6 R6Class +Progress <- R6::R6Class("Progress", + public = list( + n = NULL, + i = 0, + init_time = NULL, + stopped = FALSE, + stop_time = NULL, + min_time = NULL, + last_update = NULL, + + initialize = function(n, min_time = 0, ...) { + self$n <- n + self$min_time <- min_time + self$begin() + }, + + begin = function() { + "Initialise timer. Call this before beginning timing." + self$i <- 0 + self$last_update <- self$init_time <- now() + self$stopped <- FALSE + self + }, + + pause = function(x) { + "Sleep for x seconds. Useful for testing." + Sys.sleep(x) + self + }, + + width = function() { + getOption("width") - nchar("|100% ~ 99.9 h remaining") - 2 + }, + + tick = function() { + "Process one element" + if (self$stopped) return(self) + + if (self$i == self$n) abort("No more ticks") + self$i <- self$i + 1 + self + }, + + stop = function() { + if (self$stopped) return(self) + + self$stopped <- TRUE + self$stop_time <- now() + self + }, + + print = function(...) { + if (!isTRUE(getOption("fable.show_progress")) || # user sepecifies no progress + !interactive() || # not an interactive session + !is.null(getOption("knitr.in.progress"))) { # fable used within knitr document + return(invisible(self)) + } + + now_ <- now() + if (now_ - self$init_time < self$min_time || now_ - self$last_update < 0.05) { + return(invisible(self)) + } + self$last_update <- now_ + + if (self$stopped) { + overall <- show_time(self$stop_time - self$init_time) + if (self$i == self$n) { + cat_line("Completed after ", overall) + cat("\n") + } else { + cat_line("Killed after ", overall) + cat("\n") + } + return(invisible(self)) + } + + avg <- (now() - self$init_time) / self$i + time_left <- (self$n - self$i) * avg + nbars <- trunc(self$i / self$n * self$width()) + + cat_line( + "|", str_rep("=", nbars), str_rep(" ", self$width() - nbars), "|", + format(round(self$i / self$n * 100), width = 3), "% ", + "~", show_time(time_left), " remaining" + ) + + invisible(self) + } + ) +) + +cat_line <- function(...) { + msg <- paste(..., sep = "", collapse = "") + gap <- max(c(0, getOption("width") - nchar(msg, "width"))) + cat("\r", msg, rep.int(" ", gap), sep = "") + utils::flush.console() +} + +str_rep <- function(x, i) { + paste(rep.int(x, i), collapse = "") +} + +show_time <- function(x) { + if (x < 60) { + paste(round(x), "s") + } else if (x < 60 * 60) { + paste(round(x / 60), "m") + } else { + paste(round(x / (60 * 60)), "h") + } +} + +now <- function() proc.time()[[3]] diff --git a/R/zzz.R b/R/zzz.R index f7fc8c62..edd9c411 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -4,6 +4,13 @@ register_s3_method("pillar", "pillar_shaft", "fcdist") register_s3_method("pillar", "pillar_shaft", "hilo") + op <- options() + op.fable <- list( + fable.show_progress = TRUE + ) + toset <- !(names(op.fable) %in% names(op)) + if (any(toset)) options(op.fable[toset]) + invisible() }