purrrogress/0000755000176200001440000000000013515423060012646 5ustar liggesuserspurrrogress/NAMESPACE0000644000176200001440000000065113514402252014066 0ustar liggesusers# Generated by roxygen2: do not edit by hand export(R6_progress) export(progress_bar) export(with_progress) import(methods) import(pkgcond) import(purrr) importFrom(assertthat,is.count) importFrom(assertthat,is.flag) importFrom(assertthat,is.number) importFrom(assertthat,is.string) importFrom(assertthat,see_if) importFrom(glue,glue) importFrom(testextra,are) importFrom(utils,head) importFrom(utils,tail) purrrogress/LICENSE0000644000176200001440000000005313467301515013657 0ustar liggesusersYEAR: 2019 COPYRIGHT HOLDER: Andrew Redd purrrogress/README.md0000644000176200001440000001707613470574641014154 0ustar liggesusers # purrrogress [![Travis build status](https://travis-ci.org/halpo/purrrogress.svg?branch=master)](https://travis-ci.org/halpo/purrrogress) [![Codecov test coverage](https://codecov.io/gh/halpo/purrrogress/branch/master/graph/badge.svg)](https://codecov.io/gh/halpo/purrrogress?branch=master) The goal of purrrogress is to add as simply as possible progress bars to [`purrr`](http://purrr.tidyverse.org) mapping functions. ## Installation You can install the released version of purrrogress from [CRAN](https://CRAN.R-project.org) with: ``` r install.packages("purrrogress") ``` ## Using Progress bars can be added to any map function with the `with_progress()` function wrapped around the function to be mapped. ``` r library(purrrogress) ## basic example code fun <- function(...){ # this does nothing but take time. Sys.sleep(0.1) invisible(NULL) } invisible(map(1:100, with_progress(fun))) ``` This example doesn’t do much but illustrates the simplicity of purrrogress bars. The length of the progress bar is imputed from the variable passed to the map function as well as the title and label for the progress bar. No changes are needed to the function and all arguments are passed on as is. ### Caveat The `with_progress()` function can only impute the length if it is actually part of the map call. The following will not work. ``` r # This will not work. not_so_fun <- with_progress(fun) invisible(map(1:100, not_so_fun)) ``` This could be made to work by specifying the length if known a priori. ``` r # The fix just_less_fun <- with_progress(fun, 100) invisible(map(1:100, just_less_fun)) ``` ### Directly The progress bars used by `purrrogress` are defined in a class system described in a later section. Progress bars can be created and manipulated directly through the `progress_bar()` function. ``` r pb <- progress_bar(100, "A Title", "An informative label", type="none") ``` The type argument will determine what type of progress bar is created, windows, Tk, or none(used for testing and demonstration). # Customization The progress bar windows can be customized to display relevant information such as the number of elements completed, or the estimated time remaining. This can be accomplished through inserting [glue](https://glue.tidyverse.org/) style keywords. These keywords are added by default: - `total` - the total number of elements. - `current` - the current number of elements completed. - `frac` - an alias for `"{current}/{total}"`, giving the nicely formatted fraction of completed elements. - `percent` - the percent completed as a whole number percent. - `elapsed.time` - The total time elapsed from the start to the completion of the last `step()` or `update()` call, typically the last element completion. - `average.time` - The average time to complete each step. - `estimated.total.time` - a naive estimate of the total time remaining. Taken as the `average.time * total`. - `estimated.time.remaining` - Just what is says, `estimated.total.time - elapsed.time`. - `etr` - alias for `estimated.time.remaining` These keywords can be used in either the title or the label of progress bars to obtain more informative messages. ``` r pb <- progress_bar( 100 , title = "Test progress bar ({etr})" , label = "{frac}({percent}) completed." , initial = 50 ) pb$init() Sys.sleep(2) pb$title #> Test progress bar (00:00:02) pb$label #> 50/100(50%) completed. pb$term() ``` ## Adding Bindings In addition to those provided, additional bindings can be added to show even more information. ``` r words <- stringi::stri_rand_lipsum(1, FALSE) %>% stringi::stri_split(fixed = ' ') %>% unlist() pb <- R6_progress$new( length(words) , title = "Test Progress {current}/{total}" , label = "Working on item {current}, {word}" , bindings = list(word = ~words[pb$current+1]) ) #> Warning in ls(self, all = TRUE): partial argument match of 'all' to #> 'all.names' #> Warning in ls(private$bindings, all = TRUE): partial argument match of #> 'all' to 'all.names' pb$init() pb$label #> Working on item 0, Maecenas pb$step() pb$label #> Working on item 1, ac pb$step() pb$label #> Working on item 2, eget pb$term() ``` # Class System Additional progress bars may be defined to work within the `purrrogress` framework, however each must inherit from the base progress class, “R6 Progress Base Class” which handles the creation and management of the active bindings for titles and labels. #### Public Methods to Implement. The following are public methods for which a derived class **must** implement. - **`init()`** - This is called at the beginning of a loop or apply function. It should contain the code to actually create and show the progress bar window. Variables that are used to monitor and control the progress windows through other steps should be initialized here. It should additionally call `super$init()` to start timers. The return value should be `invisible(self)`. - **`term()`** - This is called to close any open windows, close connections and free resources. After `term()` is called the progress object should be unusable. There is no need to call `super$term()` at this time but is it provided for good practice. The return value is expected to be `invisible(NULL)`. - **`update(...)`** - This takes any number of arguments which may be used to update internal variables or displays. This should handle updating of the progress window, titles, labels, etc. The return value is expected to be `invisible(self)`. #### Other Public Methods The following are functions that are provided in the public interface for R6 progress bars but do not need to be implemented in child classes, or when implemented care should be taken to carry forward the default behavior. - **`step(n=1L, ..., keep.open=FALSE)`** - This is called to increment the internal progress counter, it in turn calls `update(...)` function the update any windows, titles and labels. The `n` argument is provided to allow for taking uneven steps. The `keep.open` argument is provided to allow for windows that stay open to show relevant information, such as total time or average time per step. If `keep.open` is false (default) when the current counter reaches the total `term()` will be called. - **`initialize(...)`** - populates the initial values of `title`, `label`, and `initial` count, which cannot be changed once specified. - **`add_binding()`** - adds an active binding which may be used in the title or label. - **`add_bindings(...)`** - a more convenient way to specify multiple bindings at once in the form of `add_bindings(name=funtion(){...})`. - **`expose(sym)`** - The most convenient way of binding variable to use in the title or label. When called the variable from the current scope is added to the available bindings so that it may be referenced in the title or label. # Acknowledgements This project was inspired by a post to [R-Bloggers](https://www.r-bloggers.com/purrring-progress-bars-adding-a-progress-bar-to-purrrmap/) by Adi Sarid. Credit goes to him for the original idea on which `purrrogress` is built. purrrogress/man/0000755000176200001440000000000013514365266013435 5ustar liggesuserspurrrogress/man/with_progress.Rd0000644000176200001440000000277013514365266016631 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/with_progress.R \name{with_progress} \alias{with_progress} \title{Apply a function with progress bars.} \usage{ with_progress(fun, total, ...) } \arguments{ \item{fun}{The function to be apply} \item{total}{The total number of elements to be mapped. If omitted an attempt will be made to infer the correct number.} \item{...}{Arguments passed on to \code{progress_bar} \describe{ \item{total}{the total number of elements} \item{title}{the title of the progress bar} \item{type}{the type of progress bar to create as a string, or an \code{R6ClassGenerator} object for a class that inherits from the "R6 Progress Base Class".} }} } \description{ Apply a function with progress bars. } \examples{ # with purrr functions long_function <- function(x, how.long=0.05){ Sys.sleep(how.long) x } \donttest{ purrr::walk(1:100, with_progress(long_function)) purrr::walk2(1:100, 0.01, with_progress(long_function)) } # with dplyr::group_map \donttest{ if(require(dplyr)){ group_function <- function(x, y, how.long=0.05){ Sys.sleep(how.long) x } group_map( group_by(mtcars, cyl, gear) , with_progress(group_function, type='line') , how.long=1/3) group_walk( group_by_all(mtcars) , with_progress(group_function, type='box') , how.long=1) } } # with standard apply functions sapply(1:100, with_progress(long_function, type='txt'), 0.001) } purrrogress/man/R6_progress.Rd0000644000176200001440000000072313514365266016141 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/R6Progress.R \docType{data} \name{R6_progress} \alias{R6_progress} \title{Base Progress bar Class} \format{An object of class \code{R6ClassGenerator} of length 24.} \usage{ R6_progress } \description{ This is the base class for all R6 progress bars. It also doubles as a null progress bar that displays no progress bar, but allows for checking values. } \keyword{datasets} purrrogress/man/is_purrr_map2_fun.Rd0000644000176200001440000000102413514365266017355 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/purrr.R \name{is_purrr_map2_fun} \alias{is_purrr_map2_fun} \title{Check if a function is a map2 derived function} \usage{ is_purrr_map2_fun(fun) } \arguments{ \item{fun}{function to test.} } \description{ Besides the obvious \link{map2} and \code{map2_*} variants, this also covers functions based off \code{map2}: \itemize{ \item \link{imap} and \code{imap_*} variants. \item \link{invoke_map} and \code{[invoke_map_*]} variants. } } purrrogress/man/progress_bar.Rd0000644000176200001440000000264313514400567016413 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/progress_bar.R \name{progress_bar} \alias{progress_bar} \title{Create a R6 progress bar directly} \usage{ progress_bar(total, title = "Progress", ..., type = getOption("progress.type", infer_type())) } \arguments{ \item{total}{the total number of elements} \item{title}{the title of the progress bar} \item{...}{passed on to the specific constructor determined by type.} \item{type}{the type of progress bar to create as a string, or an \code{R6ClassGenerator} object for a class that inherits from the "R6 Progress Base Class".} } \description{ Create a R6 progress bar directly } \examples{ \donttest{ pb_win <- progress_bar(100, "Windows Progress", type = 'win') } pb_txt <- progress_bar(100, "Text Progress", type = 'txt') pb_txt$init() # starts the timer and shows the bar. pb_txt$step() # take 1 step update progress bar. pb_txt$step(25) # take 24 steps at one time pb_txt$term() # do finishing tasks for progress bar. # The following use Unicode characters and may not work with all fonts. # DejaVu Sans Mono is one font which supports all the characters used pb_bar <- progress_bar(100, "Bar Progress", type = 'bar') pb_line <- progress_bar(100, "Line Progress", type = 'line') pb_box <- progress_bar(100, "Box Progress", type = 'box') pb_block <- progress_bar(100, "Block Progress", type = 'block') } purrrogress/DESCRIPTION0000644000176200001440000000171213515423060014355 0ustar liggesusersPackage: purrrogress Title: Add Progress Bars to Mapping Functions Version: 0.1.1 Authors@R: person(given = "Andrew", family = "Redd", role = c("aut", "cre"), email = "andrew.redd@hsc.utah.edu", comment = c(ORCID = "0000-0002-6149-2438")) Description: Provides functions to easily add progress bars to apply calls. License: MIT + file LICENSE Encoding: UTF-8 LazyData: true Imports: R6, assertthat, glue, hms, methods, pkgcond, purrr, testextra, utils, rlang RoxygenNote: 6.1.1 Language: en-US Suggests: covr, datasets, stringi, testthat, tibble Enhances: dplyr URL: https://github.com/halpo/purrrogress BugReports: https://github.com/halpo/purrrogress/issues NeedsCompilation: no Packaged: 2019-07-22 18:22:25 UTC; u0092104 Author: Andrew Redd [aut, cre] () Maintainer: Andrew Redd Repository: CRAN Date/Publication: 2019-07-22 21:10:08 UTC purrrogress/tests/0000755000176200001440000000000013470577273014030 5ustar liggesuserspurrrogress/tests/testthat/0000755000176200001440000000000013515423060015650 5ustar liggesuserspurrrogress/tests/testthat/test-apply.R0000644000176200001440000000104713473311601020077 0ustar liggesusers#! This file was automatically produced by the testextra package. #! Changes will be overwritten. context('tests extracted from file `apply.R`') #line 85 "R/apply.R" test_that('with_apply_progress', {#@testing val <- sapply( 1:5, with_progress( test_progress_status , label="{frac} items completed" , type="none") , total=5 , title = "sapply" , label = "\\d/5 items completed") expect_true(all(val)) }) purrrogress/tests/testthat/test-purrr.R0000644000176200001440000000567613514366453020153 0ustar liggesusers#! This file was automatically produced by the testextra package. #! Changes will be overwritten. context('tests extracted from file `purrr.R`') #line 31 "R/purrr.R" test_that('all_calls', {#@testing fun <- purrr::imap expect_equal( sort(all_calls(fun)) , c("`<-`", 'as_mapper', 'map2', 'vec_index')) }) #line 82 "R/purrr.R" test_that('is_purrr_map_call', {#@testing vals <- purrr::map_lgl(1:2, function(x) is_purrr_map_call(sys.call(sys.parent(1))) ) expect_true(all(vals)) v2 <- sapply(1:2, function(x) is_purrr_map_call(sys.call(sys.parent(1))) ) expect_false(any(v2)) }) #line 99 "R/purrr.R" test_that('is_purrr_frame', {#@testing vals <- purrr::map_lgl(1:2, function(x) is_purrr_frame(sys.frame(sys.parent(1))) ) expect_true(all(vals)) v2 <- sapply(1:2, function(x) is_purrr_frame(sys.frame(sys.parent(1))) ) expect_false(any(v2)) }) #line 124 "R/purrr.R" test_that('in_purrr_map', {#@testing vals <- purrr::map_lgl(1:1, function(x){ # which <- sys.parent(1):sys.nframe() # calls <- sys.calls()[which] # frames <- sys.frames()[which] # in_purrr_map(which, calls, frames) == sys.parent(1) in_purrr_map() == sys.parent(1) }) expect_true(all(vals)) v2 <- sapply(1:2, function(x) in_purrr_map( sys.parent(1):sys.nframe()) == sys.parent() ) expect_false(any(v2)) }) #line 139 "R/purrr.R" test_that('in_purrr_map nested.', {#@testing in_purrr_map nested. purrr::map(1:1, function(x){ parent <- sys.parent() inner.vals <- purrr::map_int(1:2, function(...) in_purrr_map() ) expect_true(all(inner.vals > parent)) me.val <- in_purrr_map() expect_equal(me.val, parent) }) }) #line 192 "R/purrr.R" test_that('with_purrr_progress', {#@testing purrr::map_lgl(1:5, with_progress(test_progress_status, type='none') , 5 , "purrr::map(...)" , "\\d+/\\d+ items completed" , class = "R6 Progress Base Class" ) purrr::map_lgl(1:5, with_progress( test_progress_status, type='none' , total = 10 , title = "Mapping progress" , label = "{elapsed.time}/{estimated.total.time} this will take forever" ) , total = 10 , "Mapping progress" , "this will take forever" , class = "R6 Progress Base Class" ) purrr::pmap_lgl(list(1:5), with_progress( test_progress_status, type='none' , title = "pmap progress" ) , total = 5 ) }) purrrogress/tests/testthat/test-R6_box_progress.R0000644000176200001440000001547213473562012022050 0ustar liggesusers#! This file was automatically produced by the testextra package. #! Changes will be overwritten. context('tests extracted from file `R6_box_progress.R`') #line 92 "C:/Users/u0092104/Box Sync/Projects/Personal/purrrogress/R/R6_box_progress.R" test_that('make_txt_progress_bar', {#@testing val <- make_txt_progress_bar(20, 1/3, basic.charset) expect_equal(val, "|====== |") val <- make_txt_progress_bar(20, 1/2, basic.charset) expect_equal(val, "|========= |") val <- make_txt_progress_bar(20, 0, basic.charset) expect_equal(val, "| |") val <- make_txt_progress_bar(20, 1, basic.charset) expect_equal(val, "|==================|") }) #line 249 "C:/Users/u0092104/Box Sync/Projects/Personal/purrrogress/R/R6_box_progress.R" test_that('R6_txt_progress', {#@testing pb <- R6_txt_progress$new( 1000, title = "Test text progress" , label = "{fwfrac} {bar}({percent}) {etr} remaining" , width = 50 ) expect_equal(pb$fwfrac, " 0/1000") expect_match(pb$bar, "\\| +\\|") expect_equal(pb$title, "Test text progress") expect_equal( pb$label , " 0/1000 | |(0%) NA remaining" ) expect_output( pb$step(999) , " 999/1000 |=+|\\(99%\\) 00:00:00 remaining" ) expect_output( pb$step() , "1000/1000 |=+|\\(100%\\) 00:00:00 remaining\n" ) }) #line 290 "C:/Users/u0092104/Box Sync/Projects/Personal/purrrogress/R/R6_box_progress.R" test_that('line.charset', {#@testing val <- make_txt_progress_bar(23, 1/3, line.charset) expect_equal(nchar(val), 23) get_char(8.3, line.charset$start) expected <- paste0('\u2523' , strrep('\u2501', floor(23/3-1)) , '\u2578' #< heavy left i.e. >= 50% of block , strrep(' ', 23-3-6) , '\u2502' ) expect_equal(val, expected) val <- make_txt_progress_bar(23, 1, line.charset) expect_equal(nchar(val), 23) expected <- paste0('\u2523' , strrep('\u2501', 21) , '\u252B' ) expect_equal(val, expected) }) #line 319 "C:/Users/u0092104/Box Sync/Projects/Personal/purrrogress/R/R6_box_progress.R" test_that('R6_line_progress', {#@testing pb <- R6_line_progress$new( 80, title = "Test line text progress" , label = "{fwfrac}{bar}({percent}) {etr} remaining" , width = 50 ) expect_equal(pb$fwfrac, " 0/80") expect_equal(pb$title, "Test line text progress") expect_true(pb$bar=="\u250A \u2502") expect_output(pb$init(), " 0/80(.*)\\(0%\\) NA remaining") expect_output( pb$step(), regexp = ".* 1/80(.*)\\(1%\\) ([0-9:]{8}) remaining") expect_true(pb$bar=="\u2502 \u2502") expect_output( pb$step(), regexp = ".* 2/80(.*)\\(2%\\) ([0-9:]{8}) remaining") expect_true(pb$bar=="\u2503 \u2502") expect_output( pb$step(), regexp = ".* 3/80(.*)\\(3%\\) ([0-9:]{8}) remaining") expect_true(pb$bar=="\u2520 \u2502") expect_output( pb$step(), regexp = ".* 4/80(.*)\\(5%\\) ([0-9:]{8}) remaining") expect_true(pb$bar=="\u2523 \u2502") expect_output( pb$step(), regexp = ".* 5/80(.*)\\(6%\\) ([0-9:]{8}) remaining") expect_true(pb$bar=="\u2523\u2574 \u2502") expect_output( pb$step(), regexp = ".* 6/80(.*)\\(7%\\) ([0-9:]{8}) remaining") expect_true(pb$bar=="\u2523\u2578 \u2502") expect_output( pb$step(), regexp = ".* 7/80(.*)\\(8%\\) ([0-9:]{8}) remaining") expect_true(pb$bar=="\u2523\u257E \u2502") expect_output( pb$step(), regexp = ".* 8/80(.*)\\(10%\\) ([0-9:]{8}) remaining") expect_true(pb$bar=="\u2523\u2501 \u2502") expect_output( pb$step(), regexp = ".* 9/80(.*)\\(11%\\) ([0-9:]{8}) remaining") expect_true(pb$bar=="\u2523\u2501\u2574 \u2502") expect_output(pb$step(67)) expect_true(pb$bar==paste0("\u2523", strrep("\u2501", 18), "\u2502")) expect_output(pb$step()) expect_true(pb$bar==paste0("\u2523", strrep("\u2501", 18), "\u2524")) expect_output(pb$step()) expect_true(pb$bar==paste0("\u2523", strrep("\u2501", 18), "\u2525")) expect_output(pb$step()) expect_true(pb$bar==paste0("\u2523", strrep("\u2501", 18), "\u252B")) }) #line 381 "C:/Users/u0092104/Box Sync/Projects/Personal/purrrogress/R/R6_box_progress.R" test_that('block.charset', {#@testing val <- make_txt_progress_bar(10, 9/80, block.charset) expect_equal(nchar(val), 10) expect_equal( val, "\u2588\u258F ") expect_equal( make_txt_progress_bar(10, 12/80, block.charset) , "\u2588\u258C ") }) #line 395 "C:/Users/u0092104/Box Sync/Projects/Personal/purrrogress/R/R6_box_progress.R" test_that('R6_box_progress', {#@testing pb <- R6_box_progress$new( 160, title = "Test block box progress" , label = "{fwfrac}{bar}({percent}) {etr} remaining" , width = 52 ) expect_equal(pb$fwfrac, " 0/160") expect_match(pb$bar, " {20}") expect_equal(pb$title, "Test block box progress") expect_match( pb$label, " 0/160 {20}\\(0%\\) NA remaining") expect_output(pb$init(), " 0/160 {20}\\(0%\\) NA remaining") expect_output( pb$step()) expect_match(pb$label, regexp = " 1/160(\u258F) {19}\\(0%\\) \\d\\d:\\d\\d:\\d\\d remaining") expect_output( pb$step()) expect_match(pb$label, regexp = " 2/160(\u258E) {19}\\(1%\\) \\d\\d:\\d\\d:\\d\\d remaining") expect_output( pb$step()) expect_match(pb$label, regexp = " 3/160(\u258D) {19}\\(1%\\) \\d\\d:\\d\\d:\\d\\d remaining") expect_output( pb$step()) expect_match(pb$label, regexp = " 4/160(\u258C) {19}\\(2%\\) \\d\\d:\\d\\d:\\d\\d remaining") expect_output( pb$step()) expect_match(pb$label, regexp = " 5/160(\u258B) {19}\\(3%\\) \\d\\d:\\d\\d:\\d\\d remaining") expect_output( pb$step()) expect_match(pb$label, regexp = " 6/160(\u258A) {19}\\(3%\\) \\d\\d:\\d\\d:\\d\\d remaining") expect_output( pb$step()) expect_match(pb$label, regexp = " 7/160(\u2589) {19}\\(4%\\) \\d\\d:\\d\\d:\\d\\d remaining") expect_output( pb$step()) expect_match(pb$label, regexp = " 8/160(\u2588) {19}\\(5%\\) \\d\\d:\\d\\d:\\d\\d remaining") expect_output( pb$step()) expect_match(pb$label, regexp = " 9/160(\u2588\u258F) {18}\\(5%\\) \\d\\d:\\d\\d:\\d\\d remaining") }) purrrogress/tests/testthat/test-R6Progress.R0000644000176200001440000000574413514366741021011 0ustar liggesusers#! This file was automatically produced by the testextra package. #! Changes will be overwritten. context('tests extracted from file `R6Progress.R`') #line 150 "R/R6Progress.R" test_that('R6_progress', {#@testing test <- R6_progress$new(100) expect_equal(test$title, "Progress") expect_equal(test$label, "0/100 items completed") expect_true(is.na(test$etr)) expect_identical(test$init(), test) Sys.sleep(0.1) expect_true(is.na(test$etr)) expect_equal(test$current, 0L) expect_identical(test$step(), test) expect_equal(test$current, 1L) expect_false(is.na(test$etr)) expect_equal(test$percent, "1%") expect_null(test$term()) words <- stringi::stri_rand_lipsum(1, FALSE) %>% stringi::stri_split(fixed = ' ') %>% unlist() i <- 1 pb <- R6_progress$new( length(words) , "Test Progress {current}/{total} ({estimated.time.remaining} remaining.)" , "{elapsed.time}/{estimated.total.time} estimated.\n {word}" , bindings = list(word = ~words[i]) , expose = 'i' ) expect_identical(pb$total, length(words)) expect_identical(pb$current, 0L) expect_equal(pb$title, "Test Progress 0/" %<<<% length(words) %<<<% " (NA remaining.)") expect_equal(pb$label, "NA/NA estimated.\n" %<<<% words[[1]]) expect_equal(pb$frac, "0/" %<<<% length(words)) pb$step() Sys.sleep(1) et <- pb$elapsed.time expect_is(et, 'hms') expect_true(et >= 1) at <- pb$average.time expect_is(at, 'hms') expect_true(at >= 1) expect_error(pb$expose(i, overwrite = FALSE) , class = "purrrogress-error-already-exists") expect_warning(pb$expose(i, overwrite = NA) , class = "purrrogress-warning-already-exists") expect_silent(pb$expose(i, overwrite = TRUE)) pb$add_bindings(next_word = function()words[[pb$current+2]]) }) #line 304 "R/R6Progress.R" test_that('R6_win_progress', {#@testing words <- stringi::stri_rand_lipsum(1, FALSE) %>% stringi::stri_split(fixed = ' ') %>% unlist() i <- 1 pb <- R6_win_progress$new( length(words) , "Test Progress {current}/{total} ({estimated.time.remaining} remaining.)" , "{elapsed.time}/{estimated.total.time} estimated.\n {word}" , width = 600 , bindings = list(word = ~words[i]) , show.after=2 ) expect_identical(pb$total, length(words)) expect_identical(pb$current, 0L) expect_equal(pb$title, "Test Progress 0/" %<<<% length(words) %<<<% " (NA remaining.)") expect_equal(pb$label, "NA/NA estimated.\n" %<<<% words[[1]]) expect_equal(pb$frac, "0/" %<<<% length(words)) pb$init() pb$elapsed.time }) purrrogress/tests/testthat/test-stacks.R0000644000176200001440000000265513514401070020244 0ustar liggesusers#! This file was automatically produced by the testextra package. #! Changes will be overwritten. context('tests extracted from file `stacks.R`') #line 43 "R/stacks.R" test_that('peek_progress', {#@testing expect_identical(get_progress_stack('test stack'), list()) pb1 <- progress_bar(3, show=TRUE, type='none') push_progress(pb1, 'test stack') expect_identical(get_progress_stack('test stack'), list(pb1)) expect_identical(peek_progress('test stack'), pb1) pb1$step() expect_equal(peek_progress('test stack')$current, 1L) pb2 <- progress_bar(5, title = "sub-progress", type='none') push_progress(pb2, 'test stack') expect_identical(get_progress_stack('test stack'), list(pb1, pb2)) expect_identical(peek_progress('test stack'), pb2) pop_progress('test stack') expect_identical(get_progress_stack('test stack'), list(pb1)) expect_identical(peek_progress('test stack'), pb1) pb1$step() pop_progress('test stack') expect_identical(get_progress_stack('test stack'), list()) expect_error( peek_progress('test stack') , class = "purrrogress-error-empty progress stack" ) expect_error( pop_progress('test stack') , class = "purrrogress-error-empty progress stack" ) txt <- txtProgressBar() push_progress(txt, 'test stack') expect_identical(peek_progress('test stack'), txt) }) purrrogress/tests/testthat/test-progress_bar.R0000644000176200001440000000242013514400667021445 0ustar liggesusers#! This file was automatically produced by the testextra package. #! Changes will be overwritten. context('tests extracted from file `progress_bar.R`') #line 54 "R/progress_bar.R" test_that('infer_type', {#@testing expect_equal(infer_type('Windows', TRUE), 'win') expect_equal(infer_type('Windows', FALSE), 'none') expect_equal(infer_type('Linux', TRUE), 'txt') expect_equal(infer_type('FooBar', TRUE), 'txt') expect_equal(infer_type('FooBar', FALSE), 'none') }) #line 85 "R/progress_bar.R" test_that('resolve_type', {#@testing expect_identical(resolve_type('win'), R6_win_progress) expect_error(resolve_type('tk')) expect_identical(resolve_type('txt'), R6_txt_progress) expect_identical(resolve_type('bar'), R6_line_progress) expect_identical(resolve_type('line'), R6_line_progress) expect_identical(resolve_type('box'), R6_box_progress) expect_identical(resolve_type('none'), R6_progress) expect_warning( resolve_type('foobar') , class = "purrrogress-warning-invalid progress type" ) expect_identical(suppress_warnings(resolve_type('none') , class = "purrrogress-warning-invalid progress type") , R6_progress) }) purrrogress/tests/testthat/test-group_map.R0000644000176200001440000000361213473311173020747 0ustar liggesusers#! This file was automatically produced by the testextra package. #! Changes will be overwritten. context('tests extracted from file `group_map.R`') #line 44 "R/group_map.R" test_that('with_progress_group_map', {#@testing if( requireNamespace('dplyr') & requireNamespace('tibble') & requireNamespace('datasets') ){ x <- dplyr::group_by(datasets::iris, Species) test_group_map_progress <- function(df, key, ...){ val <- test_progress_status( step = match(key$Species, unique(iris$Species)), ...) tibble::tibble(val) } val <- dplyr::group_map( dplyr::group_by(iris, Species) , with_progress(test_group_map_progress, type="none") , total=3 , title = ".dplyr::group_map. progress" , label = "\\d/3 items completed") expect_true(all(val$val)) val <- dplyr::group_map(x, with_progress(test_group_map_progress, type="none") , total=3 , title = "group_map\\(x, test_group_map_progress, ...)" , label = "\\d/3 items completed") expect_true(all(val$val)) val <- dplyr::group_map(x, with_progress(function(...){ test_group_map_progress(...) }, type="none") , total=3 , title = "group_map\\(x, ...)" , label = "\\d/3 items completed") expect_true(all(val$val)) delayedAssign('f', with_progress(test_group_map_progress, type="none")) val <- dplyr::group_map(x, f , total=3 , title = "group_map\\(x, f, \\.\\.\\.\\)" , label = "\\d/3 items completed") expect_true(all(val$val)) } }) purrrogress/tests/testthat.R0000644000176200001440000000010213470577575016011 0ustar liggesuserslibrary(testthat) library(purrrogress) test_check("purrrogress") purrrogress/R/0000755000176200001440000000000013471156065013060 5ustar liggesuserspurrrogress/R/stacks.R0000644000176200001440000000510113514401053014454 0ustar liggesusers#' @importFrom utils head tail NULL .pb.stacks <- new.env(hash = TRUE, parent = emptyenv()) get_progress_stack <- function(stack){ if (exists(stack, envir=.pb.stacks, mode='list', inherits = FALSE)) get(stack, .pb.stacks) else list=list() } set_progress_stack <- function(stack, value){ assign(stack, value, .pb.stacks) } push_progress <- function(pb, stack="progress_bars"){ if(is(pb, c('winProgressBar', 'tkProgressBar', 'txtProgressBar'))) pb <- list(pb) set_progress_stack(stack, c(get_progress_stack(stack), pb)) } pop_progress <- function(stack = "progress_bars"){ bars <- get_progress_stack(stack) if (length(bars) == 0) pkg_error("Stack" %<<% sQuote(stack) %<<% "is empty." , type = "empty progress stack" ) if (length(bars)) { pb <- utils::tail(bars, 1)[[1]] if (is(pb, "winProgressBar") | is(pb, 'tkProgressBar') | is(pb, 'txtProgressBar')){ close(pb) } else if(is.environment(pb) && exists('term', envir = pb, inherits = FALSE)){ pb$term() } set_progress_stack(stack, head(bars, -1)) } } peek_progress <- function(stack = 'progress_bars'){ bars <- get_progress_stack(stack) if (length(bars) == 0) pkg_error("No current progress bars registered" , type = "empty progress stack" ) return(bars[[length(bars)]]) } if(FALSE){#@testing expect_identical(get_progress_stack('test stack'), list()) pb1 <- progress_bar(3, show=TRUE, type='none') push_progress(pb1, 'test stack') expect_identical(get_progress_stack('test stack'), list(pb1)) expect_identical(peek_progress('test stack'), pb1) pb1$step() expect_equal(peek_progress('test stack')$current, 1L) pb2 <- progress_bar(5, title = "sub-progress", type='none') push_progress(pb2, 'test stack') expect_identical(get_progress_stack('test stack'), list(pb1, pb2)) expect_identical(peek_progress('test stack'), pb2) pop_progress('test stack') expect_identical(get_progress_stack('test stack'), list(pb1)) expect_identical(peek_progress('test stack'), pb1) pb1$step() pop_progress('test stack') expect_identical(get_progress_stack('test stack'), list()) expect_error( peek_progress('test stack') , class = "purrrogress-error-empty progress stack" ) expect_error( pop_progress('test stack') , class = "purrrogress-error-empty progress stack" ) txt <- txtProgressBar() push_progress(txt, 'test stack') expect_identical(peek_progress('test stack'), txt) } purrrogress/R/group_map.R0000644000176200001440000000674413472073313015202 0ustar liggesuserswith_progress_group_map <- function( fun , i = in_call('group_map') , title = NULL , ... , frame = sys.frame(i) ){ assert_that(!missing(fun)) total <- eval( quote(pull(count(ungroup(count(.tbl)), name="TOTAL_ROWS"), "TOTAL_ROWS")) , frame) if(is.null(title)){ call <- sys.call(i) if (is.name(call[[2]])) { if ( is.call(call[[3]]) && call[[3]][[1]] == "with_progress" && is.symbol(call[[3]][[2]]) ) title <- deparse(as.call(c( as.list(call[1:2]) , list(call[[3]][[2]]) , if (length(call)>3L) alist(...) ))) else if(is.symbol(call[[3]])) title <- deparse(as.call(c( as.list(call[1:3]) , if (length(call)>3L) alist(...) ))) else title <- deparse(as.call(c(as.list(call[1:2]), alist(...)))) } else { title <- paste(sQuote(deparse(call[[1]])), "progress") } } pb <- progress_bar(total = total, title=title, ...) push_progress(pb, "with_progress") # eval( quote(on.exit(.GlobalEnv$pop_progress(), add=TRUE)) # , frame # ) pb$init() function(...){ pb$update() on.exit(pb$step()) fun(...) } } if(FALSE){#@testing if( requireNamespace('dplyr') & requireNamespace('tibble') & requireNamespace('datasets') ){ x <- dplyr::group_by(datasets::iris, Species) test_group_map_progress <- function(df, key, ...){ val <- test_progress_status( step = match(key$Species, unique(iris$Species)), ...) tibble::tibble(val) } val <- dplyr::group_map( dplyr::group_by(iris, Species) , with_progress(test_group_map_progress, type="none") , total=3 , title = ".dplyr::group_map. progress" , label = "\\d/3 items completed") expect_true(all(val$val)) val <- dplyr::group_map(x, with_progress(test_group_map_progress, type="none") , total=3 , title = "group_map\\(x, test_group_map_progress, ...)" , label = "\\d/3 items completed") expect_true(all(val$val)) val <- dplyr::group_map(x, with_progress(function(...){ test_group_map_progress(...) }, type="none") , total=3 , title = "group_map\\(x, ...)" , label = "\\d/3 items completed") expect_true(all(val$val)) delayedAssign('f', with_progress(test_group_map_progress, type="none")) val <- dplyr::group_map(x, f , total=3 , title = "group_map\\(x, f, \\.\\.\\.\\)" , label = "\\d/3 items completed") expect_true(all(val$val)) } } if(FALSE){# Manual Testing x <- dplyr::group_by(datasets::iris, Species) group_function <- function(df, keys, how.long=0.05){ Sys.sleep(how.long) x } dplyr::group_walk( dplyr::group_by_all(iris) , with_progress(group_function, type="win", show.after=0) , how.long = 0.05 ) } purrrogress/R/progress_bar.R0000644000176200001440000000654713514400463015677 0ustar liggesusers #' Create a R6 progress bar directly #' #' @param total the total number of elements #' @param title the title of the progress bar #' @param ... passed on to the specific constructor determined by type. #' @param type the type of progress bar to create as a string, or an #' `R6ClassGenerator` object for a class that inherits from #' the "R6 Progress Base Class". #' #' @export #' @examples #' #' \donttest{ #' pb_win <- progress_bar(100, "Windows Progress", type = 'win') #' } #' pb_txt <- progress_bar(100, "Text Progress", type = 'txt') #' pb_txt$init() # starts the timer and shows the bar. #' pb_txt$step() # take 1 step update progress bar. #' pb_txt$step(25) # take 24 steps at one time #' pb_txt$term() # do finishing tasks for progress bar. #' #' # The following use Unicode characters and may not work with all fonts. #' # DejaVu Sans Mono is one font which supports all the characters used #' pb_bar <- progress_bar(100, "Bar Progress", type = 'bar') #' pb_line <- progress_bar(100, "Line Progress", type = 'line') #' pb_box <- progress_bar(100, "Box Progress", type = 'box') #' pb_block <- progress_bar(100, "Block Progress", type = 'block') #' progress_bar <- function( total , title = "Progress" , ... , type = getOption('progress.type', infer_type()) ){ type <- resolve_type(type) type$new( total=total , title=title , ...) } infer_type <- function( sysname=Sys.info()['sysname'] , is.interactive = interactive() ){ if (!is.interactive) return('none') switch( sysname , Windows = 'win' , 'txt' ) } if(FALSE){#@testing expect_equal(infer_type('Windows', TRUE), 'win') expect_equal(infer_type('Windows', FALSE), 'none') expect_equal(infer_type('Linux', TRUE), 'txt') expect_equal(infer_type('FooBar', TRUE), 'txt') expect_equal(infer_type('FooBar', FALSE), 'none') } resolve_type <- function(type = infer_type()){ if (is(type, "R6ClassGenerator")){ assert_that( identical(type, R6_progress) | identical(type$get_inherit(), R6_progress) ) return(type) } else { switch( type , win = R6_win_progress , tk = pkg_error('R6_tk_progress not implimented.') , txt = R6_txt_progress , bar = , line= R6_line_progress , block= , box = R6_box_progress , none = R6_progress , { pkg_warning("Invalid progress type", type="invalid progress type") R6_progress }) } } if(FALSE){#@testing expect_identical(resolve_type('win'), R6_win_progress) expect_error(resolve_type('tk')) expect_identical(resolve_type('txt'), R6_txt_progress) expect_identical(resolve_type('bar'), R6_line_progress) expect_identical(resolve_type('line'), R6_line_progress) expect_identical(resolve_type('box'), R6_box_progress) expect_identical(resolve_type('none'), R6_progress) expect_warning( resolve_type('foobar') , class = "purrrogress-warning-invalid progress type" ) expect_identical(suppress_warnings(resolve_type('none') , class = "purrrogress-warning-invalid progress type") , R6_progress) } purrrogress/R/R6Progress.R0000644000176200001440000003123013514366731015217 0ustar liggesusers#' @import pkgcond #' @importFrom assertthat is.flag is.string is.count is.number #' @importFrom glue glue #' @importFrom testextra are NULL # R6 Virtual Progress Bar Base Class =================================== #' Base Progress bar Class #' #' This is the base class for all R6 progress bars. #' It also doubles as a null progress bar that displays no progress bar, #' but allows for checking values. #' #' @export R6_progress <- R6::R6Class("R6 Progress Base Class", public = {list( initialize = function( total , title = "Progress" , label = "{frac} items completed" , initial = 0L , ... , bindings = list() , expose = character(0) ){ assert_that( is.count(total) , is.string(title) , is.string(label) , is.count(initial) || identical(initial, 0L) ) private$.total. <- as.integer(total) private$.title. <- title private$.label. <- label private$.current. <- as.integer(initial) private$bindings <- new.env(hash = TRUE, parent = as.environment(self)) if (!missing(bindings) && length(bindings)){ assert_that( is.list(bindings) , rlang::is_named(bindings) , all(are(bindings, c('function', 'formula'))) ) private$.add_bindings(bindings, overwrite=NA) } if (!missing(expose) && length(expose)){ assert_that(is.character(expose) , all(nchar(expose) > 0) ) purrr::map2(rlang::syms(expose), expose, private$.expose, parent.frame()) } }, init = function(){ if(!private$.initialized.){ private$.start.time. <- proc.time() private$.initialized. <- TRUE } invisible(self) }, term = function(){invisible(NULL)}, update = function(...){}, step = function(n=1L, ..., keep.open = FALSE){ if (!private$.initialized.) self$init() private$.current. <- private$.current. + n if (keep.open || private$.current. < private$.total.) self$update(...) else self$term() return(invisible(self)) }, add_binding = function(fun, name, overwrite=NA){ if (is(fun, 'formula')) fun <- rlang::as_function(fun) assert_that( is.function(fun) , rlang::is_string(name) , is.flag(overwrite) ) if ( name %in% ls(self, all.names = TRUE) | name %in% ls(private$bindings, all.names = TRUE) ) { if (isFALSE(overwrite)) pkg_error( sQuote(name) %<<% "already exists." , type = "already-exists") if (is.na(overwrite)) pkg_warning(sQuote(name) %<<% "already exists." %<<% "Overwriting previous value." , type = "already-exists") if (name %in% ls(private$bindings, all.names = TRUE)) rm(list=name, envir = private$bindings) } makeActiveBinding(name, fun, private$bindings) return(invisible(self)) }, add_bindings = function(..., overwrite=NA){ private$.add_bindings(list(...), overwrite=overwrite) }, expose = function(..., env=parent.frame(), overwrite=NA){ c <- rlang::ensyms(...) assert_that(all(map_lgl(c, is.symbol))) names(c) <- ifelse(nchar(names(c)) > 0, names(c), as.character(c)) imap(c, env=env, private$.expose, overwrite=overwrite) return(invisible(self)) } )}, active = {list( title = function()glue::glue(private$.title., .envir = private$bindings), label = function()glue::glue(private$.label., .envir = private$bindings), total = function(){private$.total.}, current = function(){private$.current.}, frac = function(){paste0(private$.current., '/', private$.total.)}, elapsed.time=function(){ (proc.time() - private$.start.time.)['elapsed'] %>% as.numeric() %>% hms::as_hms() %>% hms::round_hms(1) }, average.time = function(){ if (private$.current. == 0) return(hms::as_hms(NA_integer_)) as.numeric((proc.time() - private$.start.time.)['elapsed']/private$.current.) %>% hms::as_hms() %>% hms::round_hms(1) }, estimated.total.time = function(){ if (private$.current. == 0) return(hms::as_hms(NA_integer_)) hms::round_hms(hms::as_hms(as.numeric((proc.time() - private$.start.time.)['elapsed']/private$.current.*private$.total.)), 1) }, estimated.time.remaining = function(){ if (private$.current. == 0) return(hms::as_hms(NA_integer_)) hms::round_hms(hms::as_hms(as.numeric(self$estimated.total.time - self$elapsed.time)), 1) }, etr = function(){self$estimated.time.remaining}, percent = function(){sprintf("%d%%", floor(private$.current./private$.total.*100))} )}, private = {list( .title. = "Progress", .label. = '{frac}', .total. = 0L, .current. = 0L, .start.time. = NULL, .initialized. = FALSE, bindings = NULL, .add_bindings = function(.list, overwrite=NA){ purrr::imap(.list, self$add_binding, overwrite=overwrite) return(invisible(self)) }, .expose = function(var, name, env, overwrite=NA){ fun <- eval(substitute(function()var, list(var=var)), env) self$add_binding(fun, name, overwrite=overwrite) } )} ) if(FALSE){#@testing test <- R6_progress$new(100) expect_equal(test$title, "Progress") expect_equal(test$label, "0/100 items completed") expect_true(is.na(test$etr)) expect_identical(test$init(), test) Sys.sleep(0.1) expect_true(is.na(test$etr)) expect_equal(test$current, 0L) expect_identical(test$step(), test) expect_equal(test$current, 1L) expect_false(is.na(test$etr)) expect_equal(test$percent, "1%") expect_null(test$term()) words <- stringi::stri_rand_lipsum(1, FALSE) %>% stringi::stri_split(fixed = ' ') %>% unlist() i <- 1 pb <- R6_progress$new( length(words) , "Test Progress {current}/{total} ({estimated.time.remaining} remaining.)" , "{elapsed.time}/{estimated.total.time} estimated.\n {word}" , bindings = list(word = ~words[i]) , expose = 'i' ) expect_identical(pb$total, length(words)) expect_identical(pb$current, 0L) expect_equal(pb$title, "Test Progress 0/" %<<<% length(words) %<<<% " (NA remaining.)") expect_equal(pb$label, "NA/NA estimated.\n" %<<<% words[[1]]) expect_equal(pb$frac, "0/" %<<<% length(words)) pb$step() Sys.sleep(1) et <- pb$elapsed.time expect_is(et, 'hms') expect_true(et >= 1) at <- pb$average.time expect_is(at, 'hms') expect_true(at >= 1) expect_error(pb$expose(i, overwrite = FALSE) , class = "purrrogress-error-already-exists") expect_warning(pb$expose(i, overwrite = NA) , class = "purrrogress-warning-already-exists") expect_silent(pb$expose(i, overwrite = TRUE)) pb$add_bindings(next_word = function()words[[pb$current+2]]) } # R6 Windows Progress Bar ============================================== R6_win_progress <- R6::R6Class("R6 Windows Progress Bar", inherit = R6_progress, public = list( initialize = function( total , title = "Progress" , label = "" , label.final = "Finalizing" , initial = 0L , width = 500L , show.after = 0 # Number of seconds to pass before showing progress bar. , min.time = show.after * 5 # Show only if expected time (in seconds) is greater than max.time. , ... ){ assert_that( is.string(label.final) , is.count(width) , is.number(show.after) , is.number(min.time) ) super$initialize(total, title, label, initial, ...) private$.final. <- label.final private$.width. <- as.integer(width) private$.show.after. <- show.after if (private$.show.after. <= 0){ private$.min.time.needed.to.show. <- 0L self$init() } else { private$.min.time.needed.to.show. <- min.time } }, # nocov start update = function(label, ...){ if (!missing(label)){ assert_that(is.string(label)) self$.label. <<- label } self$show() if (!is.null(private$.pb.)) if (private$.current. < private$.total.) { utils::setWinProgressBar( pb = private$.pb. , value = private$.current. , title = self$title , label = self$label ) } else { utils::setWinProgressBar( pb = private$.pb. , value = private$.total. , title = self$title , label = self$final ) } return(invisible(self)) }, init = function(){ super$init() self$show() return(invisible(self)) }, term = function(){ if(!is.null(private$.pb.)) close(private$.pb.) private$.pb. <- NULL invisible(NULL) }, show = function(){ if ( is.null(private$.pb.) & self$elapsed.time >= private$.min.time.needed.to.show. & ( is.na(self$estimated.total.time) | self$estimated.total.time >= private$.min.time.needed.to.show. ) ) private$.pb. <- utils::winProgressBar( title = self$title , label = self$label , min = 0 , max = private$.total. , initial = private$.current. , width = private$.width. ) } # nocov end ), active = list( final = function()glue::glue(private$.final., .envir = self) ), private = list( .pb. = NULL, .width. = 500, .final.= "Finalizing", .show.after. = 1L, .min.time.needed.to.show. = 5L ) ) # Testing -------------------------------------------------------------- if(FALSE){#@testing words <- stringi::stri_rand_lipsum(1, FALSE) %>% stringi::stri_split(fixed = ' ') %>% unlist() i <- 1 pb <- R6_win_progress$new( length(words) , "Test Progress {current}/{total} ({estimated.time.remaining} remaining.)" , "{elapsed.time}/{estimated.total.time} estimated.\n {word}" , width = 600 , bindings = list(word = ~words[i]) , show.after=2 ) expect_identical(pb$total, length(words)) expect_identical(pb$current, 0L) expect_equal(pb$title, "Test Progress 0/" %<<<% length(words) %<<<% " (NA remaining.)") expect_equal(pb$label, "NA/NA estimated.\n" %<<<% words[[1]]) expect_equal(pb$frac, "0/" %<<<% length(words)) pb$init() pb$elapsed.time } if(FALSE){# Manual testing debug(pb$init) debug(pb$update) pb$init() pb <- R6_win_progress$new(100, show.after = 0) pb$term() } purrrogress/R/purrr.R0000644000176200001440000001511413511140541014342 0ustar liggesusers#' @import purrr NULL get_root_call_symbol <- function(call){ assert_that(is.call(call)) while (is.call(call)) { if ( call[[1]] == '::'){ call <- call[[3]] } else call <- call[[1]] } return(call) } if(FALSE){ call <- substitute(purrr::pmap(list(letters, Letters), ~paste(.x, "->", .y))) expect_identical(get_root_call_symbol(call), rlang::sym('pmap')) call <- substitute(pmap(list(letters, Letters), ~paste(.x, "->", .y))) expect_identical(get_root_call_symbol(call), rlang::sym('pmap')) } all_calls <- function(x){ if (is.function(x)) x<- body(x) if(!any(map_lgl(as.list(x), is.call))) return(character(0)) calls <- keep(as.list(x), is.call) c( as.character(map(calls, getElement, 1L)) , unlist(map(calls, all_calls)) ) } if(FALSE){#@testing fun <- purrr::imap expect_equal( sort(all_calls(fun)) , c("`<-`", 'as_mapper', 'map2', 'vec_index')) } dot_calls <- function(fun, cfun){ calls <- keep(as.list(body(fun)), is.call) if(!any(. <- as.character(map(calls, get_root_call_symbol)) == '.Call')) return(FALSE) any(as.character(map(calls[.], getElement, 2L)) %in% cfun) } if(FALSE){ fun <- purrr::pmap cfun <- "pmap_impl" expect_true(dot_calls(purrr::pmap, "pmap_impl")) expect_false(dot_calls(purrr::pmap, "map_impl")) expect_true(dot_calls(purrr::map, "map_impl")) } #' Check if a function is a map2 derived function #' #' Besides the obvious [map2] and `map2_*` variants, #' this also covers functions based off `map2`: #' * [imap] and `imap_*` variants. #' * [invoke_map] and `[invoke_map_*]` variants. #' #' @param fun function to test. is_purrr_map2_fun <- function(fun) dot_calls(fun, 'map2_impl') is_purrr_pmap_fun <- function(fun) dot_calls(fun, 'pmap_impl') is_purrr_map_fun <- function(fun) dot_calls(fun, 'map_impl') is_any_purrr_map_fun <- function(fun){ bod <- as.list(body(fun)) if('map' %in% all.names(body(fun), TRUE)) return(TRUE) any(purrr::map_lgl( bod, ~is.call(.) && .[[1]] == ".Call" && grepl(".*map.*_impl", deparse(.[[2]])))) } is_purrr_map_call <- function(call){ f <- call[[1]] if (is.call(f)) { if ( f[[1]] == '::' && f[[2]] == 'purrr' ){ f <- f[[3]] } else return(FALSE) } if (!is.symbol(f)) return(FALSE) grepl('map', f) } if(FALSE){#@testing vals <- purrr::map_lgl(1:2, function(x) is_purrr_map_call(sys.call(sys.parent(1))) ) expect_true(all(vals)) v2 <- sapply(1:2, function(x) is_purrr_map_call(sys.call(sys.parent(1))) ) expect_false(any(v2)) } is_purrr_frame <- function(frame){ if (is.list(frame)) return(purrr::map_lgl(frame, is_purrr_frame)) getPackageName(topenv(frame)) == 'purrr' } if(FALSE){#@testing vals <- purrr::map_lgl(1:2, function(x) is_purrr_frame(sys.frame(sys.parent(1))) ) expect_true(all(vals)) v2 <- sapply(1:2, function(x) is_purrr_frame(sys.frame(sys.parent(1))) ) expect_false(any(v2)) } in_purrr_map <- function( which = seq.int(sys.nframe()) , calls = sys.calls()[which] , frames = sys.frames()[which] ){ assert_that( length(which) == length(calls) , length(which) == length(frames) ) i <- which[base::which(is_purrr_frame(frames))] if (any(i)) i <- i[map_lgl(calls[i], is_purrr_map_call)] if (any(i)) i <- i[map_lgl(map(i, sys.function), is_any_purrr_map_fun)] if (length(i)) max(i) else FALSE } if(FALSE){#@testing vals <- purrr::map_lgl(1:1, function(x){ # which <- sys.parent(1):sys.nframe() # calls <- sys.calls()[which] # frames <- sys.frames()[which] # in_purrr_map(which, calls, frames) == sys.parent(1) in_purrr_map() == sys.parent(1) }) expect_true(all(vals)) v2 <- sapply(1:2, function(x) in_purrr_map( sys.parent(1):sys.nframe()) == sys.parent() ) expect_false(any(v2)) } if(FALSE){#@testing in_purrr_map nested. purrr::map(1:1, function(x){ parent <- sys.parent() inner.vals <- purrr::map_int(1:2, function(...) in_purrr_map() ) expect_true(all(inner.vals > parent)) me.val <- in_purrr_map() expect_equal(me.val, parent) }) } with_purrr_progress <- function( i = in_purrr_map() , title = NULL , ... , fun){ purrr.frame <- sys.frame(i) sys.call(i)[[1]] if (exists('.x', envir = purrr.frame)) { if (exists('.y', envir = purrr.frame)) total <- max( length(get('.x', envir = purrr.frame)) , length(get('.y', envir = purrr.frame)) ) else total <- length(get('.x', envir = purrr.frame)) } else if (exists('.l', envir = purrr.frame)) { total <- max(map_int(get('.l', envir=purrr.frame), length)) } else pkg_error("could not determine length.") if(is.null(title)){ call <- sys.call(i) if (!is.name(call[[2]])) { title <- deparse(as.call(c(as.list(call[1]), alist(...)))) } else if (!is.name(call[[3]])){ title <- deparse(as.call(c(as.list(call[1:2]), as.name('...')))) } else { title <- paste(sQuote(call[[1]]), "progress") } } pb <- progress_bar(total = total, title=title, ...) push_progress(pb, "with_progress") eval(quote(on.exit(quote(.GlobalEnv$pop_progress("with_progress")))), sys.frame(i)) pb$init() function(...){ pb$update() on.exit(pb$step()) fun(...) } } if(FALSE){#@testing purrr::map_lgl(1:5, with_progress(test_progress_status, type='none') , 5 , "purrr::map(...)" , "\\d+/\\d+ items completed" , class = "R6 Progress Base Class" ) purrr::map_lgl(1:5, with_progress( test_progress_status, type='none' , total = 10 , title = "Mapping progress" , label = "{elapsed.time}/{estimated.total.time} this will take forever" ) , total = 10 , "Mapping progress" , "this will take forever" , class = "R6 Progress Base Class" ) purrr::pmap_lgl(list(1:5), with_progress( test_progress_status, type='none' , title = "pmap progress" ) , total = 5 ) } purrrogress/R/test_progress_status.R0000644000176200001440000000114613470577353017521 0ustar liggesuserstest_progress_status <- function( step , total = NULL , title = NULL , label = NULL , ... , stack = 'with_progress' , class = "R6 Progress Base Class" ){ assert_that(requireNamespace('testthat')) pb <- peek_progress('with_progress') testthat::expect_equal(pb$current, step-1) if(!is.null(class)) testthat::expect_is(pb, class) if(!is.null(total)) testthat::expect_equal(pb$total, total) if(!is.null(title)) testthat::expect_match(pb$title, title) if(!is.null(label)) testthat::expect_match(pb$label, label) invisible(TRUE) } purrrogress/R/with_progress.R0000644000176200001440000000474613476034317016115 0ustar liggesusers#' @import methods NULL #' Apply a function with progress bars. #' #' @param fun The function to be apply #' @param total The total number of elements to be mapped. #' If omitted an attempt will be made to infer the #' correct number. #' @inheritDotParams progress_bar #' #' @export #' @examples #' #' # with purrr functions #' long_function <- function(x, how.long=0.05){ #' Sys.sleep(how.long) #' x #' } #' \donttest{ #' purrr::walk(1:100, with_progress(long_function)) #' purrr::walk2(1:100, 0.01, with_progress(long_function)) #' } #' #' # with dplyr::group_map #' \donttest{ #' if(require(dplyr)){ #' group_function <- function(x, y, how.long=0.05){ #' Sys.sleep(how.long) #' x #' } #' group_map( group_by(mtcars, cyl, gear) #' , with_progress(group_function, type='line') #' , how.long=1/3) #' group_walk( group_by_all(mtcars) #' , with_progress(group_function, type='box') #' , how.long=1) #' } #' } #' # with standard apply functions #' sapply(1:100, with_progress(long_function, type='txt'), 0.001) #' #' with_progress <- function( fun , total , ... ){ if(!rlang::is_function(fun)) fun <- rlang::as_function(fun, parent.frame()) if (missing(total)) { calls <- sys.calls() frames <- sys.frames() which <- seq.int(sys.nframe()) i <- max( in_purrr_map(which, calls=calls, frames=frames) , in_apply_call(calls) , in_call(c('group_map')) ) if (length(i) == 1 && is.finite(i) && i > 0) { if (getPackageName(frames[[i]]) == 'purrr') return(with_purrr_progress(i, ..., fun=fun)) call.symbols <- get_call_symbols(calls) if (call.symbols[[i]] %in% base.apply.calls) return(with_apply_progress(i, ..., fun=fun)) if (call.symbols[[i]] == 'group_map') return(with_progress_group_map(i, ..., fun=fun)) } else { stop("total is missing and could not find an appropriate" %<<% "call to associate with progress bar.") } } else { pb <- progress_bar(total = total, ...) push_progress(pb, "with_progress") pb$init() function(...){ pb$update() on.exit(pb$step()) fun(...) } } } if(FALSE){#@development f <- function(x, y){ Sys.sleep(.5) x^y } purrr::map_dbl(1:100, with_progress(f), 2) } purrrogress/R/R6_box_progress.R0000644000176200001440000004012613473562012016264 0ustar liggesusers#' @importFrom assertthat see_if get_char <- function(pct, pctmap, default, env = parent.frame()){ delayedAssign('val', default) for(f in pctmap) { lhs <- rlang::f_lhs(f) test <- rlang::eval_tidy(lhs, list(. = pct), env = parent.frame()) if (!test) break val <- rlang::f_rhs(f) } return(val) } ensure_nl <- function(s){ if (nchar(s)>0 && substring(s, first = nchar(s), last=nchar(s)) != '\n') return(paste0(s, '\n')) else return(s) } make_txt_progress_bar = function( width , pct , charset=basic.charset ){ no.start <- is.null(charset$start) no.end <- is.null(charset$end) fixed.start <- no.start || is.character(charset$start) fixed.end <- no.end || is.character(charset$end) usable.width <- width - (fixed.start&!no.start) - (fixed.end&!no.end) nc <- usable.width * pct char.start <- if (fixed.start) { if (no.start) '' else charset$start } else if (is.list(charset$start)) { get_char(nc, charset$start) } else pkg_error("Invalid value for charset$start" , type="invalid value") char.fill <- if (is.character(charset$fill)){ charset$fill } else if ( !is.null(charset$position) && is.list(charset$position) ){ get_char(1, charset$position) } else '=' char.blank <- if (is.character(charset$blank)){ charset$blank } else if ( !is.null(charset$position) && is.list(charset$position) ){ get_char(0, charset$position) } else ' ' char.position <- if ( is.null(charset$position) || (!fixed.start && nc <= 1) || (!fixed.end && width - nc < 1) || nc %% 1 == 0 ){ '' } else if (is.character(charset$position)){ charset$position } else if (is.list(charset$position)){ get_char(nc %% 1L, charset$position, char.blank) } else pkg_error( "Invalid value for charset$position" , type="invalid value") char.end <- if (fixed.end) { if (no.end) '' else charset$end } else if (is.list(charset$end)) { get_char( nc - usable.width + 1, charset$end) } else pkg_error("Invalid value for charset$end" , type="invalid value") nf <- max(min( floor(usable.width * pct - (nchar(char.start)*(!fixed.start))) , usable.width - (nchar(char.end)*(!fixed.end)) - (nchar(char.end)*(!fixed.end)) ), 0) nb <- max(0, width - nf - nchar(char.start) - nchar(char.position) - nchar(char.end) ) paste0( char.start , strrep(char.fill, nf) , char.position , strrep(char.blank, nb) , char.end ) } if(FALSE){#@testing val <- make_txt_progress_bar(20, 1/3, basic.charset) expect_equal(val, "|====== |") val <- make_txt_progress_bar(20, 1/2, basic.charset) expect_equal(val, "|========= |") val <- make_txt_progress_bar(20, 0, basic.charset) expect_equal(val, "| |") val <- make_txt_progress_bar(20, 1, basic.charset) expect_equal(val, "|==================|") } basic.charset <- list( start = "|" , fill = '=' , blank = ' ' , end = '|' ) is_valid_charmap <- function(charmap){ see_if( is.list(charmap) , all(are(charmap, 'formula')) , all(map_int(charmap, length)== 3) , all(map_lgl(map(charmap, rlang::f_rhs), is.string)) , is.string(get_char(0, charmap)) , is.string(get_char(1, charmap)) ) } is_valid_charset <- function(charset){ are.strings <- purrr::map_lgl(charset, is.string) are.lists <- purrr::map_lgl(charset, is.list) are.valid.charmaps <-purrr::map_lgl(charset, is_valid_charmap) see_if( all(are.strings | are.valid.charmaps) , all(c("fill", "blank") %in% names(charset)) | ('position' %in% names(charset) & is_valid_charmap(charset$position) ) , all(names(charset) %in% c("start", "fill", "position", "blank", "end")) , 'fill' %!in% names(charset) | is.string(charset$fill) , 'blank' %!in% names(charset) | is.string(charset$blank) ) } R6_txt_progress <- R6::R6Class("R6 Text Progress Bar", inherit = R6_progress, public = {list( initialize = function( total , title = "" , label = "{fwfrac}{bar}({percent}) {etr} remaining" , ... , width = getOption('width') , charset=basic.charset ){ super$initialize(total=total, title=title, label=label, ...) assert_that(is_valid_charset(charset)) private$charset <- charset if (private$.title. != self$test_title){ pkg_warning("Dynamic titles are not supported in text progress bars" , type="feature not supported" ) } if (!missing(width)){ if (is.number(width) && 0 < width && width < 1){ width <- as.integer(round(console.width * width)) } else { assert_that( is.count(width) , width <= getOption('width') ) } } private$total.width <- width private$infer_bar_width() }, init = function(){ { super$init() title <- self$title if(is.character(title) && nchar(title) > 0) ensure_nl(title) self$print_label() flush.console() } invisible(self) }, update = function(...){ cat('\r') flush.console() if (...length()>0) cat(ensure_nl(paste0(...))) self$print_label() flush.console() return(invisible(self)) }, term = function(){ self$update() cat('\n') flush.console() invisible(NULL) }, print_label = function(){ label <- self$label console.width <- getOption('width') if (nchar(label) > console.width) label <- substring(label, 0, console.width) cat(label) } )}, active = {list( fwfrac = function(){ format <- sprintf("%% %dd/%%d", ceiling(log10(self$total+1L))) sprintf(format, self$current, self$total) }, test_label = function()private$get_test_label(bar="==="), test_title = function(){ glue::glue_data(private$get_test_params(), private$.title., envir=private$bindings) }, bar = function(){ make_txt_progress_bar( width = private$bar.width , pct = self$current/self$total , charset = private$charset) } )}, private = {list( total.width = NULL, bar.width = NULL, charset = basic.charset, get_test_params = function(...){list( current = private$.total. , frac = paste0(private$.total., '/', private$.total.) , elapsed.time = "12:34:56" , average.time = "00:12:34" , estimated.total.time = "12:34:56" , estimated.time.remaining = "12:34:56" , etr = "12:34:56" , percent = "100%" , ...)}, get_test_env = function(...){ list2env(private$get_test_params(...), parent=private$bindings) }, get_test_label = function(...){ glue::glue_data(private$get_test_env(...), private$.label.) }, check_bar_width = function(min.bar.width = 10L){ console.width <- getOption('width') if (private$bar.width < min.bar.width) pkg_error( "Console does not have enough room for progress bar and label." , type = "label too wide") }, infer_bar_width = function() { label.width <- nchar(private$get_test_label(bar="")) console.width <- getOption('width') private$bar.width <- private$total.width - label.width } )} ) if(FALSE){#@testing pb <- R6_txt_progress$new( 1000, title = "Test text progress" , label = "{fwfrac} {bar}({percent}) {etr} remaining" , width = 50 ) expect_equal(pb$fwfrac, " 0/1000") expect_match(pb$bar, "\\| +\\|") expect_equal(pb$title, "Test text progress") expect_equal( pb$label , " 0/1000 | |(0%) NA remaining" ) expect_output( pb$step(999) , " 999/1000 |=+|\\(99%\\) 00:00:00 remaining" ) expect_output( pb$step() , "1000/1000 |=+|\\(100%\\) 00:00:00 remaining\n" ) } line.charset <- list( start = list( TRUE ~ '\u250A' #< dashed vertical , . >= 0.25 ~ '\u2502' #< light vertical , . >= 0.50 ~ '\u2503' #< heavy vertical , . >= 0.75 ~ '\u2520' #< heavy vertical light right , . >= 1.00 ~ '\u2523' ) , fill = '\u2501' #< heavy horizontal , position = list( TRUE ~ ' ' , . >= 0.25 ~ '\u2574' #< light left , . >= 0.50 ~ '\u2578' #< heavy left , . >= 0.75 ~ '\u257E' #< heavy left light right , . == 1 ~ '\u2501' #< heavy horizontal ) , blank = ' ' #< blank space , end = list( TRUE ~ '\u2502' #< light vertical , . >= 0.25 ~ '\u2524' #< light left light vertical , . >= 0.50 ~ '\u2525' #< heavy left light vertical , . >= 0.75 ~ '\u252B' #< heavy/heavy ) ) if(FALSE){#@testing val <- make_txt_progress_bar(23, 1/3, line.charset) expect_equal(nchar(val), 23) get_char(8.3, line.charset$start) expected <- paste0('\u2523' , strrep('\u2501', floor(23/3-1)) , '\u2578' #< heavy left i.e. >= 50% of block , strrep(' ', 23-3-6) , '\u2502' ) expect_equal(val, expected) val <- make_txt_progress_bar(23, 1, line.charset) expect_equal(nchar(val), 23) expected <- paste0('\u2523' , strrep('\u2501', 21) , '\u252B' ) expect_equal(val, expected) } R6_line_progress <- R6::R6Class("R6 Line Drawing Progress", inherit = R6_txt_progress, public = list( initialize = function(..., charset=line.charset) super$initialize(..., charset=charset) ) ) if(FALSE){#@testing pb <- R6_line_progress$new( 80, title = "Test line text progress" , label = "{fwfrac}{bar}({percent}) {etr} remaining" , width = 50 ) expect_equal(pb$fwfrac, " 0/80") expect_equal(pb$title, "Test line text progress") expect_true(pb$bar=="\u250A \u2502") expect_output(pb$init(), " 0/80(.*)\\(0%\\) NA remaining") expect_output( pb$step(), regexp = ".* 1/80(.*)\\(1%\\) ([0-9:]{8}) remaining") expect_true(pb$bar=="\u2502 \u2502") expect_output( pb$step(), regexp = ".* 2/80(.*)\\(2%\\) ([0-9:]{8}) remaining") expect_true(pb$bar=="\u2503 \u2502") expect_output( pb$step(), regexp = ".* 3/80(.*)\\(3%\\) ([0-9:]{8}) remaining") expect_true(pb$bar=="\u2520 \u2502") expect_output( pb$step(), regexp = ".* 4/80(.*)\\(5%\\) ([0-9:]{8}) remaining") expect_true(pb$bar=="\u2523 \u2502") expect_output( pb$step(), regexp = ".* 5/80(.*)\\(6%\\) ([0-9:]{8}) remaining") expect_true(pb$bar=="\u2523\u2574 \u2502") expect_output( pb$step(), regexp = ".* 6/80(.*)\\(7%\\) ([0-9:]{8}) remaining") expect_true(pb$bar=="\u2523\u2578 \u2502") expect_output( pb$step(), regexp = ".* 7/80(.*)\\(8%\\) ([0-9:]{8}) remaining") expect_true(pb$bar=="\u2523\u257E \u2502") expect_output( pb$step(), regexp = ".* 8/80(.*)\\(10%\\) ([0-9:]{8}) remaining") expect_true(pb$bar=="\u2523\u2501 \u2502") expect_output( pb$step(), regexp = ".* 9/80(.*)\\(11%\\) ([0-9:]{8}) remaining") expect_true(pb$bar=="\u2523\u2501\u2574 \u2502") expect_output(pb$step(67)) expect_true(pb$bar==paste0("\u2523", strrep("\u2501", 18), "\u2502")) expect_output(pb$step()) expect_true(pb$bar==paste0("\u2523", strrep("\u2501", 18), "\u2524")) expect_output(pb$step()) expect_true(pb$bar==paste0("\u2523", strrep("\u2501", 18), "\u2525")) expect_output(pb$step()) expect_true(pb$bar==paste0("\u2523", strrep("\u2501", 18), "\u252B")) } block.charset <- list(position = list( TRUE ~ ' ' , . >= 1/8 ~ '\u258F' , . >= 2/8 ~ '\u258E' , . >= 3/8 ~ '\u258D' , . >= 4/8 ~ '\u258C' , . >= 5/8 ~ '\u258B' , . >= 6/8 ~ '\u258A' , . >= 7/8 ~ '\u2589' , . == 1 ~ '\u2588' )) if(FALSE){#@testing val <- make_txt_progress_bar(10, 9/80, block.charset) expect_equal(nchar(val), 10) expect_equal( val, "\u2588\u258F ") expect_equal( make_txt_progress_bar(10, 12/80, block.charset) , "\u2588\u258C ") } R6_box_progress <- R6::R6Class("R6 Block Drawing Progress", inherit = R6_txt_progress, public = list( initialize = function(..., charset=block.charset) super$initialize(..., charset=charset) ) ) if(FALSE){#@testing pb <- R6_box_progress$new( 160, title = "Test block box progress" , label = "{fwfrac}{bar}({percent}) {etr} remaining" , width = 52 ) expect_equal(pb$fwfrac, " 0/160") expect_match(pb$bar, " {20}") expect_equal(pb$title, "Test block box progress") expect_match( pb$label, " 0/160 {20}\\(0%\\) NA remaining") expect_output(pb$init(), " 0/160 {20}\\(0%\\) NA remaining") expect_output( pb$step()) expect_match(pb$label, regexp = " 1/160(\u258F) {19}\\(0%\\) \\d\\d:\\d\\d:\\d\\d remaining") expect_output( pb$step()) expect_match(pb$label, regexp = " 2/160(\u258E) {19}\\(1%\\) \\d\\d:\\d\\d:\\d\\d remaining") expect_output( pb$step()) expect_match(pb$label, regexp = " 3/160(\u258D) {19}\\(1%\\) \\d\\d:\\d\\d:\\d\\d remaining") expect_output( pb$step()) expect_match(pb$label, regexp = " 4/160(\u258C) {19}\\(2%\\) \\d\\d:\\d\\d:\\d\\d remaining") expect_output( pb$step()) expect_match(pb$label, regexp = " 5/160(\u258B) {19}\\(3%\\) \\d\\d:\\d\\d:\\d\\d remaining") expect_output( pb$step()) expect_match(pb$label, regexp = " 6/160(\u258A) {19}\\(3%\\) \\d\\d:\\d\\d:\\d\\d remaining") expect_output( pb$step()) expect_match(pb$label, regexp = " 7/160(\u2589) {19}\\(4%\\) \\d\\d:\\d\\d:\\d\\d remaining") expect_output( pb$step()) expect_match(pb$label, regexp = " 8/160(\u2588) {19}\\(5%\\) \\d\\d:\\d\\d:\\d\\d remaining") expect_output( pb$step()) expect_match(pb$label, regexp = " 9/160(\u2588\u258F) {18}\\(5%\\) \\d\\d:\\d\\d:\\d\\d remaining") } purrrogress/R/apply.R0000644000176200001440000000514513473311522014326 0ustar liggesusersin_call <- function( consider , calls = sys.calls() ){ call.syms <- get_call_symbols(calls) j <- which(call.syms %in% consider) if (length(j)) max(j) else FALSE } if(FALSE){ call.syms <- map(calls, `[[`, 1) %>% map(deparse) %>% map_chr(head, 1) i <- which(call.syms == 'map2') j <- which(call.syms == 'mapply') sys.function(i-1) sys.function(i) sys.function(i+1) topenv(frames[[11]]) frame <- frames[[j]] ls(frame, all=TRUE) eval(quote(length(..1)), envir=frame) } get_call_symbol <- function(call){ if(is.symbol(call)) return(deparse(call)) if(is.call(call)){ if ( length(call) == 3 && is.name(call[[1]]) && call[[1]] == '::') return(get_call_symbol(call[[3]])) else return(get_call_symbol(call[[1]])) } return(NA_character_) } get_call_symbols <- function(calls = sys.calls()){ purrr::map_chr(calls, get_call_symbol) } base.apply.calls <- c('mapply', 'apply', 'sapply', 'tapply', 'lapply') in_apply_call <- function(calls = sys.calls(), ...){ in_call(base.apply.calls) } get_apply_length <- function( i = in_apply_call() , calls = sys.calls() , frames = sys.frames() ){ switch( get_call_symbols(calls)[[i]] , mapply = eval(quote(length(..1)), envir = frames[[i]]) , lapply = eval(quote(length(X)), envir = frames[[i]]) , sapply = eval(quote(length(X)), envir = frames[[i]]) , tapply = eval(quote(length(X)), envir = frames[[i]]) , apply = eval(quote(sum(dim(X)[MARGIN])), envir = frames[[i]]) ) } with_apply_progress <- function(i = in_apply_call(), title=NULL, ..., fun){ total <- get_apply_length(i) if(is.null(title)){ call <- sys.call(i) if (!is.name(call[[2]])) { title <- deparse(as.call(c(as.list(call[1]), alist(...)))) } else if (!is.name(call[[3]])){ title <- deparse(as.call(c(as.list(call[1:2]), as.name('...')))) } else { title <- paste(sQuote(call[[1]]), "progress") } } pb <- progress_bar(total = total, title=title, ...) push_progress(pb, 'with_progress') pb$init() function(...){ pb$update() on.exit(pb$step()) fun(...) } } if(FALSE){#@testing val <- sapply( 1:5, with_progress( test_progress_status , label="{frac} items completed" , type="none") , total=5 , title = "sapply" , label = "\\d/5 items completed") expect_true(all(val)) } purrrogress/NEWS.md0000644000176200001440000000042113515377167013761 0ustar liggesusers# purrrogress 0.1.1 * Bug fixes. * Examples updated. # purrrogress 0.1.0 * Initial Release * Includes support for windows progress bars. * Added support for flexible text `R6_box_progress` bars. * Added a `NEWS.md` file to track changes to the package. * Added examples.purrrogress/MD50000644000176200001440000000264513515423060013165 0ustar liggesusers7bc5946c0b2b16c3f1f81d90b04f9465 *DESCRIPTION cf3ffd570ea268634097df7093e6f753 *LICENSE dfad7e99965f8a85283a1c68bae28765 *NAMESPACE 017f031142ed7488d1b9cfe8efc73d68 *NEWS.md d9ab17f116e39d7c4f7417036e72e0f6 *R/R6Progress.R 21ac6f927014669098455f332f7aa9eb *R/R6_box_progress.R 3298376dcb7032036c4b7696e2e99112 *R/apply.R 3cdede342759e281f1c4fa1fec614f2f *R/group_map.R dd82e94554688af4d4a853f84f72240d *R/progress_bar.R ce8c5fd88de5438e441ae5188404e2a9 *R/purrr.R f0d8cd621f2d8c2b8fb03589ba09d326 *R/stacks.R ed15227c27611f44f23a855910e0d5fd *R/test_progress_status.R 4654bf392e04ad97a3f4052d3b6e019c *R/with_progress.R c6216a8ab3b3e0c0eac93cc3cc873220 *README.md c9db66eb7f38345146bc10f19cde73d1 *inst/WORDLIST 9cebb922b2a5f5ecabb2c2f62c13f4b3 *man/R6_progress.Rd 9c8682153046e6b1242c526718de61e8 *man/is_purrr_map2_fun.Rd 32d1540f3172c666f839ce550363daad *man/progress_bar.Rd ab8ebcac53d9546ef768f4664a412f80 *man/with_progress.Rd c04f56ef4c6a91bd2556e601a52c679c *tests/testthat.R aa3a86eb17a993c879c6a5c36290ba54 *tests/testthat/test-R6Progress.R 4479639d63bd601ed515184557c572ad *tests/testthat/test-R6_box_progress.R f7ffaa79104d1d439c03dab4390a2a04 *tests/testthat/test-apply.R 6e07fb94dda475b9a6d011a790d6087e *tests/testthat/test-group_map.R 48174cc5441a5f264142a2d57ae76635 *tests/testthat/test-progress_bar.R 08c136448337816aab6f555aa6ffea59 *tests/testthat/test-purrr.R 9e640a7d0da2cd5631002edfb118ff96 *tests/testthat/test-stacks.R purrrogress/inst/0000755000176200001440000000000013470573757013646 5ustar liggesuserspurrrogress/inst/WORDLIST0000644000176200001440000000005713471127731015026 0ustar liggesusersAcknowledgements Adi Codecov priori Sarid