├── .gitignore ├── .Rbuildignore ├── man ├── figures │ └── logo.png ├── break_down_cond.Rd ├── decorate_once.Rd ├── system_time_once.Rd ├── verbose_for.Rd ├── sink_once.Rd ├── surround_once.Rd ├── pb_for.Rd └── trace_once.Rd ├── NAMESPACE ├── once.Rproj ├── R ├── system_time_once.R ├── decorate_once.R ├── trace_once.R ├── sink_once.R ├── pb_repeat.R ├── pb_while.R ├── surround_once.R ├── pb_for.R └── verbose.R ├── DESCRIPTION ├── README.Rmd └── README.md /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^once\.Rproj$ 2 | ^\.Rproj\.user$ 3 | ^README\.Rmd$ 4 | -------------------------------------------------------------------------------- /man/figures/logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/moodymudskipper/once/HEAD/man/figures/logo.png -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | export(break_down_cond) 4 | export(decorate_once) 5 | export(pb_for) 6 | export(pb_repeat) 7 | export(pb_while) 8 | export(sink_once) 9 | export(surround_once) 10 | export(system_time_once) 11 | export(trace_once) 12 | export(verbose_for) 13 | export(verbose_if) 14 | export(verbose_while) 15 | export(with_once) 16 | importFrom(stats,setNames) 17 | -------------------------------------------------------------------------------- /man/break_down_cond.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/verbose.R 3 | \name{break_down_cond} 4 | \alias{break_down_cond} 5 | \title{Break down a condition} 6 | \usage{ 7 | break_down_cond(cond, env = parent.frame(), names = TRUE) 8 | } 9 | \arguments{ 10 | \item{cond}{expression} 11 | 12 | \item{env}{environment} 13 | 14 | \item{names}{boolean} 15 | } 16 | \description{ 17 | Used by \code{verbose_if()} and \code{verbose_while()} and exported for convenience 18 | } 19 | -------------------------------------------------------------------------------- /once.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: No 4 | SaveWorkspace: No 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | AutoAppendNewline: Yes 16 | StripTrailingWhitespace: Yes 17 | LineEndingConversion: Posix 18 | 19 | BuildType: Package 20 | PackageUseDevtools: Yes 21 | PackageInstallArgs: --no-multiarch --with-keep.source 22 | PackageRoxygenize: rd,collate,namespace 23 | -------------------------------------------------------------------------------- /R/system_time_once.R: -------------------------------------------------------------------------------- 1 | #' Print the system.time of a Function's Next Call 2 | #' 3 | #' This doesn't affect the function's output, which would not be the case 4 | #' if we ran `surround_once(f, system.time, gcFirst)` 5 | #' 6 | #' @param f function 7 | #' @inheritParams base::system.time 8 | #' 9 | #' @return invisible() 10 | #' @export 11 | #' @examples 12 | #' system_time_once(sample) 13 | #' x <- sample(1e6) 14 | system_time_once <- function(f, gcFirst = TRUE){ 15 | eval.parent(substitute(surround_once( 16 | f, 17 | function(expr){ 18 | print(system.time(x <- expr, gcFirst)) 19 | x} 20 | ))) 21 | } 22 | 23 | 24 | -------------------------------------------------------------------------------- /man/decorate_once.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/decorate_once.R 3 | \name{decorate_once} 4 | \alias{decorate_once} 5 | \title{Apply a function operator to a function for one call only} 6 | \usage{ 7 | decorate_once(f, decorator, ...) 8 | } 9 | \arguments{ 10 | \item{f}{a function} 11 | 12 | \item{decorator}{a function operator} 13 | 14 | \item{...}{additional argument passed to decorator} 15 | } 16 | \description{ 17 | Apply a function operator to a function for one call only 18 | } 19 | \examples{ 20 | decorate_once(is.logical, Negate) 21 | is.logical(TRUE) 22 | is.logical(TRUE) 23 | } 24 | -------------------------------------------------------------------------------- /man/system_time_once.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/system_time_once.R 3 | \name{system_time_once} 4 | \alias{system_time_once} 5 | \title{Print the system.time of a Function's Next Call} 6 | \usage{ 7 | system_time_once(f, gcFirst = TRUE) 8 | } 9 | \arguments{ 10 | \item{f}{function} 11 | 12 | \item{gcFirst}{Logical - should a garbage collection be performed 13 | immediately before the timing? Default is \code{TRUE}.} 14 | } 15 | \value{ 16 | invisible() 17 | } 18 | \description{ 19 | This doesn't affect the function's output, which would not be the case 20 | if we ran \code{surround_once(f, system.time, gcFirst)} 21 | } 22 | \examples{ 23 | system_time_once(sample) 24 | x <- sample(1e6) 25 | } 26 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: once 2 | Title: A Collection of Single Use Function Operators 3 | Version: 0.0.0.9000 4 | Authors@R: 5 | person(given = "Antoine", 6 | family = "Fabri", 7 | role = c("aut", "cre"), 8 | email = "antoine.fabri@gmail.com") 9 | Description: once provides a collection of single use function operators. These are functions that modify a function for one call only, in the same fashion as debugonce does in base R. 10 | License: GPL-3 11 | Encoding: UTF-8 12 | LazyData: true 13 | Roxygen: list(markdown = TRUE) 14 | RoxygenNote: 7.1.0 15 | Imports: 16 | progress, 17 | vctrs 18 | Suggests: 19 | withr 20 | URL: https://github.com/moodymudskipper/once 21 | BugReports: https://github.com/moodymudskipper/once/issues 22 | -------------------------------------------------------------------------------- /R/decorate_once.R: -------------------------------------------------------------------------------- 1 | #' Apply a function operator to a function for one call only 2 | #' 3 | #' @param f a function 4 | #' @param decorator a function operator 5 | #' @param ... additional argument passed to decorator 6 | #' 7 | #' @export 8 | #' @examples 9 | #' decorate_once(is.logical, Negate) 10 | #' is.logical(TRUE) 11 | #' is.logical(TRUE) 12 | decorate_once <- function(f, decorator, ...) { 13 | 14 | f_sym <- substitute(f) 15 | f_nm <- deparse(f_sym) 16 | f2 <- args(f) 17 | env <- parent.frame() 18 | body(f2) <- bquote({ 19 | on.exit({ 20 | if(identical(environment(f), env)){ 21 | assign(.(f_nm), f, envir = env) 22 | } 23 | }) 24 | rm(.(f_sym), envir = env) 25 | # edit call to replace f() by decorator(f)() and run 26 | call <- sys.call() 27 | call[[1]] <- quote(.(as.call(c(substitute(decorator),f, eval(substitute(alist(...))))))) 28 | eval.parent(call) 29 | }) 30 | environment(f2) <- environment() 31 | assign(f_nm, value = f2, envir = env) 32 | invisible() 33 | } 34 | -------------------------------------------------------------------------------- /man/verbose_for.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/verbose.R 3 | \name{verbose_for} 4 | \alias{verbose_for} 5 | \alias{verbose_if} 6 | \alias{verbose_while} 7 | \title{verbose control flow} 8 | \usage{ 9 | verbose_for(fun = identity) 10 | 11 | verbose_if() 12 | 13 | verbose_while() 14 | } 15 | \arguments{ 16 | \item{fun}{a function to apply on \code{for}'s iterator} 17 | } 18 | \description{ 19 | These functions make \code{for}, \code{while} or \code{if} more talkative for their next call. 20 | \code{verbose_for()} will print the iterator, or the latter transformed by the \code{fun} 21 | argument. \code{verbose_if()} and \code{verbose_while()} will break down the boolean 22 | condition and display it as a one row \code{data.frame}. 23 | } 24 | \examples{ 25 | roses_are_red <- TRUE 26 | violets_are_blue <- TRUE 27 | love <- 1i 28 | verbose_if() 29 | if (is.logical(love) || roses_are_red && violets_are_blue) 30 | print("Sugar is sweet my love, but not as sweet as you.") 31 | 32 | x <- 1 33 | y <- 2 34 | verbose_while() 35 | while(x < 5 && y > 0) x <- x + 1 36 | 37 | verbose_for(dim) 38 | l <- list(iris, cars) 39 | for (x in l) { 40 | print(head(x,1)) 41 | } 42 | } 43 | -------------------------------------------------------------------------------- /R/trace_once.R: -------------------------------------------------------------------------------- 1 | #' Trace a function once 2 | #' 3 | #' Works like trace but the function will return to normal after a single run. 4 | #' It has a couple more differences : `print` is `FALSE` by default, and it 5 | #' gains a `...` argument which is an often more convenient alternative to 6 | #' the `tracer` argument. 7 | #' 8 | #' @inheritParams base::trace 9 | #' @param ... unquoted expressions, if used rather than the `tracer` argument, 10 | #' will be quoted and turned into the `tracer` argument fed to `trace()` 11 | #' 12 | #' @export 13 | #' 14 | #' @examples 15 | #' add <- function(x, y) x + y 16 | #' trace_once(add, print("entering 'add'")) 17 | #' add(1,3) 18 | #' 19 | #' # after a calls the behavior returns to normal 20 | #' add(1,3) 21 | trace_once <- function(what, ..., tracer, exit, at, print = FALSE, signature, 22 | where = topenv(parent.frame()), edit = FALSE){ 23 | mc <- match.call(expand.dots = FALSE) 24 | # replace trace_once call by trace call 25 | mc[[1]] <- quote(trace) 26 | 27 | if(...length()){ 28 | if (!missing(tracer)) 29 | stop("you can't use both `...` and `tracer` argument\n", 30 | "use `...` to feed unquoted expressions and tracer` to feed a quoted expression") 31 | mc[["tracer"]] <- substitute(quote({...})) 32 | mc[["..."]] <- NULL 33 | } 34 | if(missing(print)) mc[["print"]] <- FALSE 35 | 36 | # define or append exit argument to untrace 37 | mc[["exit"]] <- 38 | if (missing(exit)) substitute(quote(eval.parent(quote(untrace(what))))) 39 | else c(as.expression(exit), substitute(eval.parent(quote(untrace(what))))) 40 | eval.parent(mc) 41 | invisible() 42 | } 43 | -------------------------------------------------------------------------------- /man/sink_once.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/sink_once.R 3 | \name{sink_once} 4 | \alias{sink_once} 5 | \title{Sink the Output of a Function Once} 6 | \usage{ 7 | sink_once(f, file, append = FALSE, type = "output", split = FALSE) 8 | } 9 | \arguments{ 10 | \item{f}{a function} 11 | 12 | \item{file}{a writable \link[base]{connection} or a character string naming the 13 | file to write to, or \code{NULL} to stop sink-ing.} 14 | 15 | \item{append}{logical. If \code{TRUE}, output will be appended to 16 | \code{file}; otherwise, it will overwrite the contents of 17 | \code{file}.} 18 | 19 | \item{type}{either "output", "message", or a vector containing both, they can 20 | be abbreviated} 21 | 22 | \item{split}{logical: if \code{TRUE}, output will be sent to the new 23 | sink and to the current output stream, like the Unix program \code{tee}.} 24 | } 25 | \value{ 26 | \code{invisible()} 27 | } 28 | \description{ 29 | Works a lot like \code{base::sink()} except that it's applied on the output of a specific 30 | function (only once). There is no need to call \code{sink()} a second time to end 31 | the output diversion. The other difference is that one can feed 32 | \code{type = c("output", "message")} rather than choose one of them or call \code{sink()} 33 | for each one. 34 | } 35 | \examples{ 36 | greet <- function(x,y){ 37 | message(x) 38 | print(y) 39 | } 40 | 41 | file <- tempfile() 42 | sink_once(greet, file, type = c("o","m")) 43 | 44 | # output is diverted 45 | greet("Hi", "What's up?") 46 | 47 | # let's read it back 48 | readLines(file) 49 | 50 | # further calls work normally 51 | greet("Hi", "What's up?") 52 | } 53 | -------------------------------------------------------------------------------- /man/surround_once.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/surround_once.R 3 | \name{surround_once} 4 | \alias{surround_once} 5 | \alias{with_once} 6 | \title{Surround a function call once} 7 | \usage{ 8 | surround_once(f, surround_fun, ...) 9 | 10 | with_once(f, ..., with_fun = with) 11 | } 12 | \arguments{ 13 | \item{f}{a function} 14 | 15 | \item{surround_fun}{a surrounding function used by surround_once} 16 | 17 | \item{...}{additional parameters passed to surround_fun} 18 | 19 | \item{with_fun}{a surrounding function used by with_once} 20 | } 21 | \description{ 22 | Some functions, such as \code{suppressWarnings()}, take an expression as their main 23 | input. \code{surround_once()} 24 | proposes a way to modify a function for one call so it behaves as if it were 25 | surrounded by this surrounding function. \code{with()} also takes an expression, but 26 | in second position, which makes it a bit awkward to use with \code{surround_once()}, 27 | \code{with_once()} solves this issue and can be used with all functions sharing 28 | the syntax (e.g. the \verb{with_*} functions of the withr package). 29 | } 30 | \examples{ 31 | add <- function(x, y) { 32 | warning("we will perform an addition!") 33 | x + y 34 | } 35 | 36 | surround_once(add, suppressWarnings) 37 | add(1,2) 38 | add(1,2) 39 | 40 | Sepal.Length <- 1:3 41 | with_once(head, iris) 42 | head(Sepal.Length, 2) 43 | head(Sepal.Length, 2) 44 | 45 | # we can get `with_once()`'s behavior with `surround_once()` but 46 | # we must name the data argument as it comes first in `with()` 47 | surround_once(head, with, data = iris) 48 | head(Sepal.Length, 2) 49 | head(Sepal.Length, 2) 50 | 51 | \dontrun{ 52 | #' with_once(print,list(digits = 3), with_fun = withr::with_options) 53 | print(pi) 54 | print(pi) 55 | } 56 | } 57 | -------------------------------------------------------------------------------- /R/sink_once.R: -------------------------------------------------------------------------------- 1 | #' Sink the Output of a Function Once 2 | #' 3 | #' Works a lot like `base::sink()` except that it's applied on the output of a specific 4 | #' function (only once). There is no need to call `sink()` a second time to end 5 | #' the output diversion. The other difference is that one can feed 6 | #' `type = c("output", "message")` rather than choose one of them or call `sink()` 7 | #' for each one. 8 | #' 9 | #' @inheritParams base::sink 10 | #' @param f a function 11 | #' @param type either "output", "message", or a vector containing both, they can 12 | #' be abbreviated 13 | #' 14 | #' @return `invisible()` 15 | #' 16 | #' @examples 17 | #' greet <- function(x,y){ 18 | #' message(x) 19 | #' print(y) 20 | #' } 21 | #' 22 | #' file <- tempfile() 23 | #' sink_once(greet, file, type = c("o","m")) 24 | #' 25 | #' # output is diverted 26 | #' greet("Hi", "What's up?") 27 | #' 28 | #' # let's read it back 29 | #' readLines(file) 30 | #' 31 | #' # further calls work normally 32 | #' greet("Hi", "What's up?") 33 | #' @export 34 | sink_once <- function( 35 | f, 36 | file, 37 | append = FALSE, 38 | type = "output", 39 | split = FALSE){ 40 | 41 | type <- match.arg(type, choices = c("output", "message"), several.ok = TRUE) 42 | if(missing(file)) stop("`file` cannot be missing") 43 | 44 | sink_calls_enter <- lapply(type, function(x) bquote(sink( 45 | file = `*con*`, append = .(append), type = .(x), split = .(split)))) 46 | 47 | sink_calls_enter <- c(bquote(`*con*` <- file(.(file))), sink_calls_enter) 48 | 49 | sink_calls_exit <- lapply(type, function(x) bquote(sink(type = .(x)))) 50 | 51 | trace_call <- bquote( 52 | trace_once( 53 | .(substitute(f)), 54 | tracer = quote(.(as.call(c(quote(`{`), sink_calls_enter)))), 55 | exit = quote(.(as.call(c(quote(`{`), sink_calls_exit)))))) 56 | 57 | eval.parent(trace_call) 58 | invisible() 59 | } 60 | -------------------------------------------------------------------------------- /R/pb_repeat.R: -------------------------------------------------------------------------------- 1 | #' @export 2 | #' @rdname pb_for 3 | pb_repeat <- 4 | function( 5 | # all args of progress::progress_bar$new() except `stream` which is 6 | # deprecated 7 | total, 8 | format = "[:bar] :percent", 9 | width = options("width")[[1]] - 2, 10 | complete = "=", 11 | incomplete = "-", 12 | current =">", 13 | callback = invisible, # doc doesn't give default but this seems to work ok 14 | clear = TRUE, 15 | show_after = .2, 16 | force = FALSE, 17 | message = NULL, 18 | tokens = alist()) { 19 | if(missing(total)) 20 | stop("you must provide the argument `total` to `pb_repeat()` to give a length to the bar") 21 | 22 | # create the function that will replace `repeat` 23 | f <- function(expr){ 24 | # to avoid notes at CMD check 25 | PB <- EXPR <- TOKENS <- NULL 26 | 27 | # forward all arguments to progress::progress_bar$new() and add 28 | # a `total` argument compted from `seq` argument 29 | pb <- progress::progress_bar$new( 30 | format = format, width = width, complete = complete, 31 | incomplete = incomplete, current = current, 32 | callback = callback, 33 | clear = clear, show_after = show_after, force = force, 34 | total = total) 35 | if(!is.null(message)) pb$message(message) 36 | 37 | # using on.exit allows us to self destruct `repeat` if relevant even if 38 | # the call fails. 39 | # It also allows us to send to the local environment the changed/created 40 | # variables in their last state, even if the call fails (like standard repeat) 41 | on.exit({ 42 | list2env(mget(ls(env),envir = env), envir = parent.frame()) 43 | rm(`repeat`,envir = parent.frame()) 44 | }) 45 | 46 | # we build a regular `repeat` loop call with an updated loop code including 47 | # progress bar. 48 | # it is executed in a dedicated environment 49 | env <- new.env(parent = parent.frame()) 50 | eval(substitute( 51 | env = list(EXPR = do.call(substitute, list(substitute(expr),list(message = pb$message))), 52 | TOKENS = tokens, PB = pb 53 | ), 54 | base::`repeat`({ 55 | EXPR 56 | if(PB$finished) { 57 | #copyEnv(progress_bar$new(), PB) 58 | # browser() 59 | (function(pb){ 60 | pb$.__enclos_env__$private$current <- 0 61 | pb$.__enclos_env__$private$complete <- FALSE 62 | pb$finished <- FALSE}) (PB) 63 | PB$message("Progress bar finished, starting a new one") 64 | } 65 | PB$tick() 66 | })), envir = env) 67 | } 68 | # override `repeat` in the parent frame 69 | assign("repeat", value = f,envir = parent.frame()) 70 | invisible() 71 | } 72 | -------------------------------------------------------------------------------- /R/pb_while.R: -------------------------------------------------------------------------------- 1 | #' @export 2 | #' @rdname pb_for 3 | pb_while <- 4 | function( 5 | # all args of progress::progress_bar$new() except `stream` which is 6 | # deprecated 7 | total, 8 | format = "[:bar] :percent", 9 | width = options("width")[[1]] - 2, 10 | complete = "=", 11 | incomplete = "-", 12 | current =">", 13 | callback = invisible, # doc doesn't give default but this seems to work ok 14 | clear = TRUE, 15 | show_after = .2, 16 | force = FALSE, 17 | message = NULL, 18 | tokens = alist()) { 19 | if(missing(total)) 20 | stop("you must provide the argument `total` to `pb_while()` to give a length to the bar") 21 | 22 | # create the function that will replace `while` 23 | f <- function(cond, expr){ 24 | # to avoid notes at CMD check 25 | PB <- COND <- EXPR <- TOKENS <- NULL 26 | 27 | # forward all arguments to progress::progress_bar$new() and add 28 | # a `total` argument compted from `seq` argument 29 | pb <- progress::progress_bar$new( 30 | format = format, width = width, complete = complete, 31 | incomplete = incomplete, current = current, 32 | callback = callback, 33 | clear = clear, show_after = show_after, force = force, 34 | total = total) 35 | if(!is.null(message)) pb$message(message) 36 | 37 | # using on.exit allows us to self destruct `while` if relevant even if 38 | # the call fails. 39 | # It also allows us to send to the local environment the changed/created 40 | # variables in their last state, even if the call fails (like standard while) 41 | on.exit({ 42 | list2env(mget(ls(env),envir = env), envir = parent.frame()) 43 | rm(`while`,envir = parent.frame()) 44 | }) 45 | 46 | # we build a regular `while` loop call with an updated loop code including 47 | # progress bar. 48 | # it is executed in a dedicated environment 49 | env <- new.env(parent = parent.frame()) 50 | eval(substitute( 51 | env = list(COND = substitute(cond), 52 | EXPR = do.call(substitute, list(substitute(expr),list(message = pb$message))), 53 | TOKENS = tokens, PB = pb 54 | ), 55 | base::`while`(COND,{ 56 | EXPR 57 | if(PB$finished) { 58 | #copyEnv(progress_bar$new(), PB) 59 | # browser() 60 | (function(pb){ 61 | pb$.__enclos_env__$private$current <- 0 62 | pb$.__enclos_env__$private$complete <- FALSE 63 | pb$finished <- FALSE}) (PB) 64 | PB$message("Progress bar finished, starting a new one") 65 | } 66 | PB$tick() 67 | })), envir = env) 68 | } 69 | # override `while` in the parent frame 70 | assign("while", value = f,envir = parent.frame()) 71 | invisible() 72 | } 73 | -------------------------------------------------------------------------------- /R/surround_once.R: -------------------------------------------------------------------------------- 1 | #' Surround a function call once 2 | #' 3 | #' Some functions, such as `suppressWarnings()`, take an expression as their main 4 | #' input. `surround_once()` 5 | #' proposes a way to modify a function for one call so it behaves as if it were 6 | #' surrounded by this surrounding function. `with()` also takes an expression, but 7 | #' in second position, which makes it a bit awkward to use with `surround_once()`, 8 | #' `with_once()` solves this issue and can be used with all functions sharing 9 | #' the syntax (e.g. the `with_*` functions of the withr package). 10 | #' 11 | #' @param f a function 12 | #' @param surround_fun a surrounding function used by surround_once 13 | #' @param with_fun a surrounding function used by with_once 14 | #' @param ... additional parameters passed to surround_fun 15 | #' 16 | #' @export 17 | #' 18 | #' @examples 19 | #' add <- function(x, y) { 20 | #' warning("we will perform an addition!") 21 | #' x + y 22 | #' } 23 | #' 24 | #' surround_once(add, suppressWarnings) 25 | #' add(1,2) 26 | #' add(1,2) 27 | #' 28 | #' Sepal.Length <- 1:3 29 | #' with_once(head, iris) 30 | #' head(Sepal.Length, 2) 31 | #' head(Sepal.Length, 2) 32 | #' 33 | #' # we can get `with_once()`'s behavior with `surround_once()` but 34 | #' # we must name the data argument as it comes first in `with()` 35 | #' surround_once(head, with, data = iris) 36 | #' head(Sepal.Length, 2) 37 | #' head(Sepal.Length, 2) 38 | #' 39 | #' \dontrun{ 40 | #' #' with_once(print,list(digits = 3), with_fun = withr::with_options) 41 | #' print(pi) 42 | #' print(pi) 43 | #' } 44 | surround_once <- function(f, surround_fun, ...){ 45 | f_sym <- substitute(f) 46 | f_nm <- deparse(f_sym) 47 | f2 <- args(f) 48 | env <- parent.frame() 49 | body(f2) <- bquote({ 50 | on.exit({ 51 | if(identical(environment(f), env)){ 52 | assign(.(f_nm), f, envir = env) 53 | } 54 | }) 55 | rm(.(f_sym), envir = env) 56 | call <- sys.call() 57 | call[[1]] <- f 58 | eval.parent(substitute( 59 | .(as.call(c(substitute(surround_fun), quote(CALL), eval(substitute(alist(...)))))), 60 | list(CALL = call) 61 | )) 62 | }) 63 | environment(f2) <- environment() 64 | assign(f_nm, value = f2, envir = env) 65 | invisible() 66 | } 67 | 68 | #' @export 69 | #' @rdname surround_once 70 | with_once <- function(f, ..., with_fun = with){ 71 | f_sym <- substitute(f) 72 | f_nm <- deparse(f_sym) 73 | f2 <- args(f) 74 | env <- parent.frame() 75 | dots <- eval(substitute(alist(...))) 76 | body(f2) <- bquote({ 77 | on.exit({ 78 | if(identical(environment(f), env)){ 79 | assign(.(f_nm), f, envir = env) 80 | } 81 | }) 82 | rm(.(f_sym), envir = env) 83 | call <- sys.call() 84 | call[[1]] <- f 85 | eval.parent(substitute( 86 | .(as.call(c(substitute(with_fun), dots[1], quote(CALL), dots[-1]))), 87 | list(CALL = call) 88 | )) 89 | }) 90 | environment(f2) <- environment() 91 | assign(f_nm, value = f2, envir = env) 92 | invisible() 93 | } 94 | -------------------------------------------------------------------------------- /man/pb_for.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/pb_for.R, R/pb_repeat.R, R/pb_while.R 3 | \name{pb_for} 4 | \alias{pb_for} 5 | \alias{pb_repeat} 6 | \alias{pb_while} 7 | \title{Use a progress bar with regular for loops} 8 | \usage{ 9 | pb_for( 10 | format = "[:bar] :percent", 11 | width = options("width")[[1]] - 2, 12 | complete = "=", 13 | incomplete = "-", 14 | current = ">", 15 | callback = invisible, 16 | clear = TRUE, 17 | show_after = 0.2, 18 | force = FALSE, 19 | message = NULL, 20 | tokens = alist() 21 | ) 22 | 23 | pb_repeat( 24 | total, 25 | format = "[:bar] :percent", 26 | width = options("width")[[1]] - 2, 27 | complete = "=", 28 | incomplete = "-", 29 | current = ">", 30 | callback = invisible, 31 | clear = TRUE, 32 | show_after = 0.2, 33 | force = FALSE, 34 | message = NULL, 35 | tokens = alist() 36 | ) 37 | 38 | pb_while( 39 | total, 40 | format = "[:bar] :percent", 41 | width = options("width")[[1]] - 2, 42 | complete = "=", 43 | incomplete = "-", 44 | current = ">", 45 | callback = invisible, 46 | clear = TRUE, 47 | show_after = 0.2, 48 | force = FALSE, 49 | message = NULL, 50 | tokens = alist() 51 | ) 52 | } 53 | \arguments{ 54 | \item{format}{The format of the progress bar.} 55 | 56 | \item{width}{Width of the progress bar.} 57 | 58 | \item{complete}{Completion character.} 59 | 60 | \item{incomplete}{Incomplete character.} 61 | 62 | \item{current}{Current character.} 63 | 64 | \item{callback}{Callback function to call when the progress bar finishes. 65 | The progress bar object itself is passed to it as the single parameter.} 66 | 67 | \item{clear}{Whether to clear the progress bar on completion.} 68 | 69 | \item{show_after}{Amount of time in seconds, after which the progress bar is 70 | shown on the screen. For very short processes, it is probably not worth 71 | showing it at all.} 72 | 73 | \item{force}{Whether to force showing the progress bar, even if the given (or default) stream does not seem to support it.} 74 | 75 | \item{message}{A message to display on top of the bar} 76 | 77 | \item{tokens}{A list of unevaluated expressions, using \code{alist}, to be passed 78 | passed to the \code{tick} method of the progress bar} 79 | 80 | \item{total}{for \code{pb_while()} and \code{pb_repeat()}, an estimation of the 81 | number of iteration.} 82 | } 83 | \description{ 84 | These functions wrap the progress bar utilities of the \emph{progress} package 85 | to be able to use progress bar with regular \code{for}, \code{while} and \code{repeat} loops conveniently. 86 | They forward all their 87 | parameters to \code{progress::progress_bar$new()}. \code{pb_while()} and \code{pb_repeat()} 88 | require the \code{total} argument. 89 | } 90 | \examples{ 91 | pb_for() 92 | for (i in 1:10) { 93 | # DO SOMETHING 94 | Sys.sleep(0.5) 95 | } 96 | 97 | pb_for(format = "Working hard: [:bar] :percent :elapsed", 98 | callback = function(x) message("Were'd done!")) 99 | for (i in 1:10) { 100 | # DO SOMETHING 101 | Sys.sleep(0.5) 102 | } 103 | } 104 | -------------------------------------------------------------------------------- /man/trace_once.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/trace_once.R 3 | \name{trace_once} 4 | \alias{trace_once} 5 | \title{Trace a function once} 6 | \usage{ 7 | trace_once( 8 | what, 9 | ..., 10 | tracer, 11 | exit, 12 | at, 13 | print = FALSE, 14 | signature, 15 | where = topenv(parent.frame()), 16 | edit = FALSE 17 | ) 18 | } 19 | \arguments{ 20 | \item{what}{the name, possibly \code{\link[base]{quote}()}d, of a function 21 | to be traced or untraced. For \code{untrace} or for \code{trace} 22 | with more than one argument, more than one name can be given in the 23 | quoted form, and the same action will be applied to each one. For 24 | \dQuote{hidden} functions such as S3 methods in a namespace, 25 | \code{where = *} typically needs to be specified as well.} 26 | 27 | \item{...}{unquoted expressions, if used rather than the \code{tracer} argument, 28 | will be quoted and turned into the \code{tracer} argument fed to \code{trace()}} 29 | 30 | \item{tracer}{either a \link[base]{function} or an unevaluated expression. The 31 | function will be called or the expression will be evaluated either 32 | at the beginning of the call, or before those steps in the call 33 | specified by the argument \code{at}. 34 | See the details section.} 35 | 36 | \item{exit}{either a \code{\link[base]{function}} or an unevaluated expression. The 37 | function will be called or the expression will be evaluated on 38 | exiting the function. 39 | See the details section.} 40 | 41 | \item{at}{optional numeric vector or list. If supplied, \code{tracer} 42 | will be called just before the corresponding step in the body of the 43 | function. 44 | See the details section. } 45 | 46 | \item{print}{If \code{TRUE} (as per default), a descriptive line is 47 | printed before any trace expression is evaluated.} 48 | 49 | \item{signature}{ If this argument is supplied, it should be a 50 | signature for a method for function \code{what}. In this case, the 51 | method, and \emph{not} the function itself, is traced.} 52 | 53 | \item{where}{where to look for the function to be 54 | traced; by default, the top-level environment of the call to 55 | \code{trace}. 56 | 57 | An important use of this argument is to trace functions from a 58 | package which are \dQuote{hidden} or called from another package. 59 | The namespace mechanism imports the functions to be called (with the 60 | exception of functions in the base package). The functions being 61 | called are \emph{not} the same objects seen from the top-level (in 62 | general, the imported packages may not even be attached). 63 | Therefore, you must ensure that the correct versions are being 64 | traced. The way to do this is to set argument \code{where} to a 65 | function in the namespace (or that namespace). The tracing 66 | computations will then start looking in the environment of that 67 | function (which will be the namespace of the corresponding package). 68 | (Yes, it's subtle, but the semantics here are central to how 69 | namespaces work in \R.) 70 | } 71 | 72 | \item{edit}{ For complicated tracing, such as tracing within a loop 73 | inside the function, you will need to insert the desired calls by 74 | editing the body of the function. If so, supply the \code{edit} 75 | argument either as \code{TRUE}, or as the name of the editor you 76 | want to use. Then \code{trace()} will call \code{\link{edit}} and 77 | use the version of the function after you edit it. See the details 78 | section for additional information. 79 | } 80 | } 81 | \description{ 82 | Works like trace but the function will return to normal after a single run. 83 | It has a couple more differences : \code{print} is \code{FALSE} by default, and it 84 | gains a \code{...} argument which is an often more convenient alternative to 85 | the \code{tracer} argument. 86 | } 87 | \examples{ 88 | add <- function(x, y) x + y 89 | trace_once(add, print("entering 'add'")) 90 | add(1,3) 91 | 92 | # after a calls the behavior returns to normal 93 | add(1,3) 94 | } 95 | -------------------------------------------------------------------------------- /R/pb_for.R: -------------------------------------------------------------------------------- 1 | #' Use a progress bar with regular for loops 2 | #' 3 | #' These functions wrap the progress bar utilities of the *progress* package 4 | #' to be able to use progress bar with regular `for`, `while` and `repeat` loops conveniently. 5 | #' They forward all their 6 | #' parameters to `progress::progress_bar$new()`. `pb_while()` and `pb_repeat()` 7 | #' require the `total` argument. 8 | #' 9 | #' @param total for `pb_while()` and `pb_repeat()`, an estimation of the 10 | #' number of iteration. 11 | #' @param format The format of the progress bar. 12 | #' @param width Width of the progress bar. 13 | #' @param complete Completion character. 14 | #' @param incomplete Incomplete character. 15 | #' @param current Current character. 16 | #' @param callback Callback function to call when the progress bar finishes. 17 | #' The progress bar object itself is passed to it as the single parameter. 18 | #' @param clear Whether to clear the progress bar on completion. 19 | #' @param show_after Amount of time in seconds, after which the progress bar is 20 | #' shown on the screen. For very short processes, it is probably not worth 21 | #' showing it at all. 22 | #' @param force Whether to force showing the progress bar, even if the given (or default) stream does not seem to support it. 23 | #' @param tokens A list of unevaluated expressions, using `alist`, to be passed 24 | #' passed to the `tick` method of the progress bar 25 | #' @param message A message to display on top of the bar 26 | #' 27 | #' @export 28 | #' 29 | #' @examples 30 | #' pb_for() 31 | #' for (i in 1:10) { 32 | #' # DO SOMETHING 33 | #' Sys.sleep(0.5) 34 | #' } 35 | #' 36 | #' pb_for(format = "Working hard: [:bar] :percent :elapsed", 37 | #' callback = function(x) message("Were'd done!")) 38 | #' for (i in 1:10) { 39 | #' # DO SOMETHING 40 | #' Sys.sleep(0.5) 41 | #' } 42 | pb_for <- 43 | function( 44 | # all args of progress::progress_bar$new() except `total` which needs to be 45 | # infered from the 2nd argument of the `for` call, and `stream` which is 46 | # deprecated 47 | format = "[:bar] :percent", 48 | width = options("width")[[1]] - 2, 49 | complete = "=", 50 | incomplete = "-", 51 | current =">", 52 | callback = invisible, # doc doesn't give default but this seems to work ok 53 | clear = TRUE, 54 | show_after = .2, 55 | force = FALSE, 56 | message = NULL, 57 | tokens = alist()){ 58 | 59 | # create the function that will replace `for` 60 | f <- function(it, seq, expr){ 61 | # to avoid notes at CMD check 62 | PB <- IT <- SEQ <- EXPR <- TOKENS <- NULL 63 | 64 | # forward all arguments to progress::progress_bar$new() and add 65 | # a `total` argument compted from `seq` argument 66 | pb <- progress::progress_bar$new( 67 | format = format, width = width, complete = complete, 68 | incomplete = incomplete, current = current, 69 | callback = callback, 70 | clear = clear, show_after = show_after, force = force, 71 | total = length(seq)) 72 | if(!is.null(message)) pb$message(message) 73 | 74 | # using on.exit allows us to self destruct `for` if relevant even if 75 | # the call fails. 76 | # It also allows us to send to the local environment the changed/created 77 | # variables in their last state, even if the call fails (like standard for) 78 | on.exit({ 79 | list2env(mget(ls(env),envir = env), envir = parent.frame()) 80 | rm(`for`,envir = parent.frame()) 81 | }) 82 | 83 | # we build a regular `for` loop call with an updated loop code including 84 | # progress bar. 85 | # it is executed in a dedicated environment 86 | env <- new.env(parent = parent.frame()) 87 | eval(substitute( 88 | env = list(IT = substitute(it), SEQ = substitute(seq), 89 | EXPR = do.call(substitute, list(substitute(expr),list(message = pb$message))), 90 | TOKENS = tokens, PB = pb 91 | ), 92 | base::`for`(IT, SEQ,{ 93 | EXPR 94 | PB$tick() 95 | })), envir = env) 96 | } 97 | # override `for` in the parent frame 98 | assign("for", value = f,envir = parent.frame()) 99 | invisible() 100 | } 101 | -------------------------------------------------------------------------------- /R/verbose.R: -------------------------------------------------------------------------------- 1 | #' verbose control flow 2 | #' 3 | #' These functions make `for`, `while` or `if` more talkative for their next call. 4 | #' `verbose_for()` will print the iterator, or the latter transformed by the `fun` 5 | #' argument. `verbose_if()` and `verbose_while()` will break down the boolean 6 | #' condition and display it as a one row `data.frame`. 7 | #' 8 | #' @param fun a function to apply on `for`'s iterator 9 | #' @importFrom stats setNames 10 | #' @export 11 | #' @examples 12 | #' roses_are_red <- TRUE 13 | #' violets_are_blue <- TRUE 14 | #' love <- 1i 15 | #' verbose_if() 16 | #' if (is.logical(love) || roses_are_red && violets_are_blue) 17 | #' print("Sugar is sweet my love, but not as sweet as you.") 18 | #' 19 | #' x <- 1 20 | #' y <- 2 21 | #' verbose_while() 22 | #' while(x < 5 && y > 0) x <- x + 1 23 | #' 24 | #' verbose_for(dim) 25 | #' l <- list(iris, cars) 26 | #' for (x in l) { 27 | #' print(head(x,1)) 28 | #' } 29 | verbose_for <- function(fun = identity) { 30 | # create the function that will replace `for` 31 | 32 | f <- function(it, seq, expr){ 33 | # remove modified for already 34 | rm(`for`,envir = parent.frame()) 35 | 36 | # break down the condition and print 37 | print(fun(it)) 38 | 39 | # reevaluate the call 40 | eval.parent(substitute( 41 | for (it in seq){ 42 | print(fun(it)) 43 | expr 44 | })) 45 | } 46 | body(f) <- do.call(substitute, list(body(f), list(fun = substitute(fun)))) 47 | # override `if` in the parent frame 48 | assign("for", value = f,envir = parent.frame()) 49 | invisible() 50 | } 51 | 52 | 53 | #' @export 54 | #' @rdname verbose_for 55 | verbose_if <- function() { 56 | # create the function that will replace `if` 57 | f <- function(cond, yes, no){ 58 | # remove modified if already 59 | rm(`if`,envir = parent.frame()) 60 | 61 | # break down the condition and print 62 | print(break_down_cond(substitute(cond))) 63 | 64 | # reevaluate the call 65 | eval.parent(sys.call()) 66 | } 67 | # override `if` in the parent frame 68 | assign("if", value = f,envir = parent.frame()) 69 | } 70 | 71 | #' @export 72 | #' @rdname verbose_for 73 | verbose_while <- function() { 74 | # create the function that will replace `while` 75 | f <- function(cond, expr){ 76 | # remove modified if already 77 | rm(`while`,envir = parent.frame()) 78 | 79 | # reevaluate the call, printing the breakdown before going through expr 80 | eval.parent(substitute({ 81 | print(break_down_cond(quote(cond))) 82 | while(cond){ 83 | expr 84 | print(break_down_cond(quote(cond), names = FALSE)) 85 | } 86 | }) 87 | ) 88 | } 89 | # override `if` in the parent frame 90 | assign("while", value = f,envir = parent.frame()) 91 | invisible() 92 | } 93 | 94 | 95 | # breakdown condition into a one row data frame 96 | breakdown <- function(expr, l = list(), env = parent.frame()){ 97 | 98 | if(!is.call(expr)) 99 | return(append(l, setNames(list(eval(expr, envir = env)), deparse(expr)))) 100 | 101 | # if "!", breakdown negated expression 102 | if(identical(expr[[1]], quote(`!`))) 103 | return(breakdown(expr[[2]], l, env)) 104 | 105 | # if is.* function, apply (for POC) heuristic 106 | if(grepl("^is[._]", deparse(expr[[1]]))) { 107 | val <- eval(expr, envir = env) 108 | if(val) 109 | l <- append(l, setNames(list(TRUE), deparse(expr))) 110 | else 111 | l <- append(l, setNames( 112 | paste("FALSE:", vctrs::vec_ptype_abbr(eval(expr[[2]], envir = env))), deparse(expr))) 113 | return(l) 114 | } 115 | l <- append(l, setNames(list(eval(expr, envir = env)), deparse(expr))) 116 | 117 | # if `&&`, breakdown both sides 118 | if(identical(expr[[1]], quote(`&&`))){ 119 | l <- breakdown(expr[[2]], l, env) 120 | l <- breakdown(expr[[3]], l, env) 121 | return(l) 122 | } 123 | 124 | # if `||`, breakdown lhs and sometimes rhs if lhs is FALSE 125 | if(identical(expr[[1]], quote(`||`))){ 126 | l <- breakdown(expr[[2]], l, env) 127 | 128 | if( l[[length(l)]] == "TRUE") # is.logical(l[[length(l)]]) && 129 | # if lhs is TRUE we don't go further 130 | l <- append(l, setNames(list("*ignored*"), deparse(expr[[3]]))) 131 | else 132 | # else we breakdown the rhs too 133 | l <- breakdown(expr[[3]], l, env) 134 | return(l) 135 | } 136 | 137 | # if comparison, breakdown both sides unless they're not language 138 | if(list(expr[[1]]) %in% c(quote(`<`), quote(`<=`), quote(`>`), quote(`>=`))){ 139 | if(is.language(expr[[2]])) l <- breakdown(expr[[2]], l, env) 140 | if(is.language(expr[[3]])) l <- breakdown(expr[[3]], l, env) 141 | return(l) 142 | } 143 | l 144 | } 145 | 146 | #' Break down a condition 147 | #' 148 | #' Used by `verbose_if()` and `verbose_while()` and exported for convenience 149 | #' @param cond expression 150 | #' @param env environment 151 | #' @param names boolean 152 | #' @export 153 | break_down_cond <- function(cond, env = parent.frame(), names = TRUE){ 154 | bd <- breakdown(cond, env = env) 155 | nms <- paste0("`",names(bd),"`") 156 | if(!names) nms <- gsub("."," ", nms) 157 | setNames(as.data.frame(bd), nms) 158 | } 159 | 160 | 161 | -------------------------------------------------------------------------------- /README.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | output: github_document 3 | --- 4 | 5 | 6 | 7 | ```{r, include = FALSE} 8 | knitr::opts_chunk$set( 9 | collapse = TRUE, 10 | comment = "#>", 11 | fig.path = "man/figures/README-", 12 | out.width = "100%" 13 | ) 14 | ``` 15 | 16 | # once 17 | 18 | `once` provides a collection of single use function operators. These are functions 19 | that modify a function for one call only. `debugonce()` is a base R function that 20 | matches this description already, and its approach is generalized. 21 | 22 | The modified functions include control flow constructs as you can see below. 23 | 24 | * `pb_for()`, `pb_while()` and `pb_repeat()` add a progress bar to `for`, `while` or `repeat` loops. 25 | It wraps the package *progress* and leverages its flexibility. 26 | * `verbose_if()` and `verbose_while()` print a breakdown of the boolean condition 27 | * `verbose_for()` prints the iterator, or the latter modified by a give transformation function 28 | * `trace_once()` is essentially like trace but for single use 29 | * `system_time_once()` prints the `system.time()` of the next relevant call 30 | * `sink_once()` uses `sink()` to divert the ouput of the next relevant call 31 | * `surround_once()` surrounds the next relevant call with a surrounding function, such as 32 | `suppressWarnings` 33 | * `with_once()` uses `with()` a single time on the next relevant call, and support similar 34 | functions such as `withr::with_*` functions 35 | * `decorate_once()` applies a decorator (a.k.a function operator or adverb) to a function 36 | for a single call 37 | 38 | Using these functions is often more compact that alternatives, but they are other 39 | advantages : 40 | 41 | * arguably more readable in many case 42 | * Avoid parenthesis overload 43 | * Avoid having to insert closing parenthesis at an awkward place, and associated 44 | potential mistakes 45 | * Can be used to decorate a step of a magrittr pipe chain without making a mess 46 | * trivial to comment in and out when debugging 47 | 48 | ## Installation 49 | 50 | Install with: 51 | 52 | ``` r 53 | remotes::install_github("moodymudskipper/once") 54 | ``` 55 | 56 | ## Examples 57 | 58 | ```{r} 59 | library(once) 60 | ``` 61 | 62 | 63 | ### progress bars 64 | 65 | You'll have to run those yourself to see the progress bar. 66 | 67 | ```{r example, eval = FALSE} 68 | # just call pb_for() to get a progress bar 69 | pb_for() 70 | for (i in 1:10) { 71 | Sys.sleep(1) 72 | } 73 | 74 | # leverage features of {progress} package 75 | pb_for(format = "Working hard: [:bar] :percent :elapsed", 76 | callback = function(x) message("Were'd done!")) 77 | for (i in 1:10) { 78 | Sys.sleep(1) 79 | } 80 | 81 | # also for while and repeat! 82 | # but we must provide expected iteration number 83 | 84 | # if we estimate too high, bar is not completed 85 | pb_while(20) 86 | x <- 1 87 | while (x < 10) { 88 | Sys.sleep(1) 89 | x <- x + 1 90 | } 91 | 92 | # if we estimate too low, another bar starts 93 | pb_repeat(5) 94 | x <- 1 95 | repeat { 96 | Sys.sleep(1) 97 | x <- x + 1 98 | if(x == 10) break 99 | } 100 | 101 | ``` 102 | 103 | ### verbose control flows 104 | 105 | ```{r} 106 | roses_are_red <- TRUE 107 | violets_are_blue <- TRUE 108 | love <- 1i 109 | verbose_if() 110 | if (is.logical(love) || roses_are_red && violets_are_blue) 111 | print("Sugar is sweet my love, but not as sweet as you.") 112 | 113 | x <- 1 114 | y <- 2 115 | verbose_while() 116 | while(x < 5 && y > 0) x <- x + 1 117 | 118 | verbose_for(dim) 119 | l <- list(iris, cars) 120 | for (x in l) { 121 | print(head(x,1)) 122 | } 123 | ``` 124 | 125 | ### ... and all the rest! 126 | 127 | `trace_once()` is essentially like trace but for single use, it gained a 128 | `...` argument to pass unquoted expression more easily. 129 | 130 | ```{r} 131 | add <- function(x, y) x + y 132 | trace_once(add, print(typeof(x))) 133 | add(3, 4) 134 | ``` 135 | 136 | `system_time_once()` prints the `system.time()` of the next relevant call. 137 | 138 | 139 | ```{r} 140 | system_time_once(sample) 141 | x <- sample(1e6) 142 | x <- sample(1e6) 143 | ``` 144 | 145 | 146 | `sink_once()` uses `sink()` to divert the ouput of the next relevant call. 147 | 148 | ```{r, eval = FALSE} 149 | greet <- function(x,y){ 150 | message(x) 151 | print(y) 152 | } 153 | 154 | file <- tempfile() 155 | sink_once(greet, file, type = c("o","m")) # c("o","m") for output AND message 156 | 157 | # output is diverted 158 | greet("Hi", "What's up?") 159 | 160 | # let's read it back 161 | readLines(file) 162 | #> [1] "Hi" "[1] \"What's up?\"" 163 | 164 | # further calls work normally 165 | greet("Hi", "What's up?") 166 | #> Hi 167 | #> [1] "What's up?" 168 | ``` 169 | 170 | `surround_once()` surrounds the next relevant call with a surrounding function, such as 171 | `suppressWarnings`. 172 | 173 | `with_once()` uses `with()` a single time on the next relevant call, and support similar 174 | functions such as `withr::with_*` functions. 175 | 176 | ```{r} 177 | add <- function(x, y) { 178 | warning("we will perform an addition!") 179 | x + y 180 | } 181 | 182 | surround_once(add, suppressWarnings) 183 | add(1,2) 184 | add(1,2) 185 | 186 | Sepal.Length <- 1:3 187 | with_once(head, iris) 188 | head(Sepal.Length, 2) 189 | head(Sepal.Length, 2) 190 | 191 | # we can get `with_once()`'s behavior with `surround_once()` but 192 | # we must name the data argument as it comes first in `with()` 193 | surround_once(head, with, data = iris) 194 | head(Sepal.Length, 2) 195 | head(Sepal.Length, 2) 196 | 197 | with_once(print,list(digits = 3), with_fun = withr::with_options) 198 | print(pi) 199 | print(pi) 200 | ``` 201 | 202 | `decorate_once()` applies a decorator (a.k.a function operator or adverb) to a function 203 | for a single call. 204 | 205 | ```{r} 206 | decorate_once(is.logical, Negate) 207 | is.logical(TRUE) 208 | is.logical(TRUE) 209 | ``` 210 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | # once 5 | 6 | `once` provides a collection of single use function operators. These are 7 | functions that modify a function for one call only. `debugonce()` is a 8 | base R function that matches this description already, and its approach 9 | is generalized. 10 | 11 | The modified functions include control flow constructs as you can see 12 | below. 13 | 14 | - `pb_for()`, `pb_while()` and `pb_repeat()` add a progress bar to 15 | `for`, `while` or `repeat` loops. It wraps the package *progress* 16 | and leverages its flexibility. 17 | - `verbose_if()` and `verbose_while()` print a breakdown of the 18 | boolean condition 19 | - `verbose_for()` prints the iterator, or the latter modified by a 20 | give transformation function 21 | - `trace_once()` is essentially like trace but for single use 22 | - `system_time_once()` prints the `system.time()` of the next relevant 23 | call 24 | - `sink_once()` uses `sink()` to divert the ouput of the next relevant 25 | call 26 | - `surround_once()` surrounds the next relevant call with a 27 | surrounding function, such as `suppressWarnings` 28 | - `with_once()` uses `with()` a single time on the next relevant call, 29 | and support similar functions such as `withr::with_*` functions 30 | - `decorate_once()` applies a decorator (a.k.a function operator or 31 | adverb) to a function for a single call 32 | 33 | Using these functions is often more compact that alternatives, but they 34 | are other advantages : 35 | 36 | - arguably more readable in many case 37 | - Avoid parenthesis overload 38 | - Avoid having to insert closing parenthesis at an awkward place, and 39 | associated potential mistakes 40 | - Can be used to decorate a step of a magrittr pipe chain without 41 | making a mess 42 | - trivial to comment in and out when debugging 43 | 44 | ## Installation 45 | 46 | Install with: 47 | 48 | ``` r 49 | remotes::install_github("moodymudskipper/once") 50 | ``` 51 | 52 | ## Examples 53 | 54 | ``` r 55 | library(once) 56 | ``` 57 | 58 | ### progress bars 59 | 60 | You’ll have to run those yourself to see the progress bar. 61 | 62 | ``` r 63 | # just call pb_for() to get a progress bar 64 | pb_for() 65 | for (i in 1:10) { 66 | Sys.sleep(1) 67 | } 68 | 69 | # leverage features of {progress} package 70 | pb_for(format = "Working hard: [:bar] :percent :elapsed", 71 | callback = function(x) message("Were'd done!")) 72 | for (i in 1:10) { 73 | Sys.sleep(1) 74 | } 75 | 76 | # also for while and repeat! 77 | # but we must provide expected iteration number 78 | 79 | # if we estimate too high, bar is not completed 80 | pb_while(20) 81 | x <- 1 82 | while (x < 10) { 83 | Sys.sleep(1) 84 | x <- x + 1 85 | } 86 | 87 | # if we estimate too low, another bar starts 88 | pb_repeat(5) 89 | x <- 1 90 | repeat { 91 | Sys.sleep(1) 92 | x <- x + 1 93 | if(x == 10) break 94 | } 95 | ``` 96 | 97 | ### verbose control flows 98 | 99 | ``` r 100 | roses_are_red <- TRUE 101 | violets_are_blue <- TRUE 102 | love <- 1i 103 | verbose_if() 104 | if (is.logical(love) || roses_are_red && violets_are_blue) 105 | print("Sugar is sweet my love, but not as sweet as you.") 106 | #> `is.logical(love) || roses_are_red && violets_are_blue` `is.logical(love)` 107 | #> 1 TRUE FALSE: cpl 108 | #> `roses_are_red && violets_are_blue` `roses_are_red` `violets_are_blue` 109 | #> 1 TRUE TRUE TRUE 110 | #> [1] "Sugar is sweet my love, but not as sweet as you." 111 | 112 | x <- 1 113 | y <- 2 114 | verbose_while() 115 | while(x < 5 && y > 0) x <- x + 1 116 | #> `x < 5 && y > 0` `x < 5` `x` `y > 0` `y` 117 | #> 1 TRUE TRUE 1 TRUE 2 118 | #> 119 | #> 1 TRUE TRUE 2 TRUE 2 120 | #> 121 | #> 1 TRUE TRUE 3 TRUE 2 122 | #> 123 | #> 1 TRUE TRUE 4 TRUE 2 124 | #> 125 | #> 1 FALSE FALSE 5 TRUE 2 126 | 127 | verbose_for(dim) 128 | l <- list(iris, cars) 129 | for (x in l) { 130 | print(head(x,1)) 131 | } 132 | #> NULL 133 | #> [1] 150 5 134 | #> Sepal.Length Sepal.Width Petal.Length Petal.Width Species 135 | #> 1 5.1 3.5 1.4 0.2 setosa 136 | #> [1] 50 2 137 | #> speed dist 138 | #> 1 4 2 139 | ``` 140 | 141 | ### … and all the rest\! 142 | 143 | `trace_once()` is essentially like trace but for single use, it gained a 144 | `...` argument to pass unquoted expression more easily. 145 | 146 | ``` r 147 | add <- function(x, y) x + y 148 | trace_once(add, print(typeof(x))) 149 | add(3, 4) 150 | #> [1] "double" 151 | #> [1] 7 152 | ``` 153 | 154 | `system_time_once()` prints the `system.time()` of the next relevant 155 | call. 156 | 157 | ``` r 158 | system_time_once(sample) 159 | x <- sample(1e6) 160 | #> user system elapsed 161 | #> 0.09 0.00 0.09 162 | x <- sample(1e6) 163 | ``` 164 | 165 | `sink_once()` uses `sink()` to divert the ouput of the next relevant 166 | call. 167 | 168 | ``` r 169 | greet <- function(x,y){ 170 | message(x) 171 | print(y) 172 | } 173 | 174 | file <- tempfile() 175 | sink_once(greet, file, type = c("o","m")) # c("o","m") for output AND message 176 | 177 | # output is diverted 178 | greet("Hi", "What's up?") 179 | 180 | # let's read it back 181 | readLines(file) 182 | #> [1] "Hi" "[1] \"What's up?\"" 183 | 184 | # further calls work normally 185 | greet("Hi", "What's up?") 186 | #> Hi 187 | #> [1] "What's up?" 188 | ``` 189 | 190 | `surround_once()` surrounds the next relevant call with a surrounding 191 | function, such as `suppressWarnings`. 192 | 193 | `with_once()` uses `with()` a single time on the next relevant call, and 194 | support similar functions such as `withr::with_*` functions. 195 | 196 | ``` r 197 | add <- function(x, y) { 198 | warning("we will perform an addition!") 199 | x + y 200 | } 201 | 202 | surround_once(add, suppressWarnings) 203 | add(1,2) 204 | #> [1] 3 205 | add(1,2) 206 | #> Warning in add(1, 2): we will perform an addition! 207 | #> [1] 3 208 | 209 | Sepal.Length <- 1:3 210 | with_once(head, iris) 211 | head(Sepal.Length, 2) 212 | #> [1] 5.1 4.9 213 | head(Sepal.Length, 2) 214 | #> [1] 1 2 215 | 216 | # we can get `with_once()`'s behavior with `surround_once()` but 217 | # we must name the data argument as it comes first in `with()` 218 | surround_once(head, with, data = iris) 219 | head(Sepal.Length, 2) 220 | #> [1] 5.1 4.9 221 | head(Sepal.Length, 2) 222 | #> [1] 1 2 223 | 224 | with_once(print,list(digits = 3), with_fun = withr::with_options) 225 | print(pi) 226 | #> [1] 3.14 227 | print(pi) 228 | #> [1] 3.141593 229 | ``` 230 | 231 | `decorate_once()` applies a decorator (a.k.a function operator or 232 | adverb) to a function for a single call. 233 | 234 | ``` r 235 | decorate_once(is.logical, Negate) 236 | is.logical(TRUE) 237 | #> [1] FALSE 238 | is.logical(TRUE) 239 | #> [1] TRUE 240 | ``` 241 | --------------------------------------------------------------------------------