Nothing
#' 'Shiny' progress bar, but can run without reactive context
#' @param title character, task description
#' @param max maximum number of items in the queue
#' @param ... passed to \code{shiny::Progress$new(...)}
#' @param quiet suppress console output, ignored in shiny context.
#' @param session 'shiny' session, default is current reactive domain
#' @param log function when running locally, default is \code{NULL},
#' which redirects to \code{\link{cat2}}
#' @param shiny_auto_close logical, automatically close 'shiny' progress bar
#' once current observer is over. Default is \code{FALSE}. If setting to
#' \code{TRUE}, then it's equivalent to
#' \code{p <- progress2(...); on.exit({p$close()}, add = TRUE)}.
#'
#' @return A list of functions:
#' \describe{
#' \item{\code{inc(detail, message = NULL, amount = 1, ...)}}{
#' Increase progress bar by \code{amount} (default is 1).
#' }
#' \item{\code{close()}}{
#' Close the progress
#' }
#' \item{\code{reset(detail = '', message = '', value = 0)}}{
#' Reset the progress to \code{value} (default is 0), and reset information
#' }
#' \item{\code{get_value()}}{
#' Get current progress value
#' }
#' \item{\code{is_closed()}}{
#' Returns logical value if the progress is closed or not.
#' }
#' }
#'
#' @examples
#'
#' progress <- progress2('Task A', max = 2)
#' progress$inc('Detail 1')
#' progress$inc('Detail 2')
#' progress$close()
#'
#' # Check if progress is closed
#' progress$is_closed()
#'
#' # ------------------------------ Shiny Example ------------------------------
#' library(shiny)
#' library(dipsaus)
#'
#' ui <- fluidPage(
#' actionButtonStyled('do', 'Click Here', type = 'primary')
#' )
#'
#' server <- function(input, output, session) {
#' observeEvent(input$do, {
#' updateActionButtonStyled(session, 'do', disabled = TRUE)
#' progress <- progress2('Task A', max = 10, shiny_auto_close = TRUE)
#' lapply(1:10, function(ii){
#' progress$inc(sprintf('Detail %d', ii))
#' Sys.sleep(0.2)
#' })
#' updateActionButtonStyled(session, 'do', disabled = FALSE)
#' })
#' }
#'
#' if(interactive()){
#' shinyApp(ui, server)
#' }
#'
#' @export
progress2 <- function( title, max = 1, ..., quiet = FALSE,
session = shiny::getDefaultReactiveDomain(),
shiny_auto_close = FALSE, log = NULL){
if(missing(title) || is.null(title)){ title <- '' }
if( length(title) > 1 ){ title <- paste(title, collapse = '')}
if( inherits(session, c('ShinySession', 'session_proxy', 'R6')) ){
within_shiny <- TRUE
}else{
within_shiny <- FALSE
}
current <- 0
closed <- FALSE
get_value <- function(){ current }
is_closed <- function(){ closed }
logger <- function(..., .quiet = quiet, level = 'DEFAULT', bullet = 'play'){
if(!.quiet){
if(is.function(log)){
log(...)
}else{
cat2(..., level=level, bullet=bullet, end = "\r", append = TRUE)
}
}
}
if( quiet || !within_shiny ){
progress <- NULL
logger(sprintf("[%s]: initializing...", title), level = 'DEFAULT', bullet = 'play')
inc <- function(detail, message = NULL, amount = 1, ...){
stopifnot2(!closed, msg = 'progress is closed')
quiet <- c(list(...)[['quiet']], quiet)[[1]]
# if message is updated
if(!is.null(message) && length(message) == 1){ title <<- message }
current <<- amount + current
logger(sprintf("[%s]: %s (%d out of %d)", title, detail, round(current), ceiling(max)),
level = 'DEFAULT', bullet = 'arrow_right', .quiet = quiet)
}
close <- function(message = 'Finished'){
closed <<- TRUE
logger(message, level = 'DEFAULT', bullet = 'stop')
}
reset <- function(detail = '', message = '', value = 0){
title <<- message
current <<- value
}
}else{
progress <- shiny::Progress$new(session = session, max = max, ...)
inc <- function(detail, message = NULL, amount = 1, ...){
if(!is.null(message) && length(message) == 1){ title <<- message }
current <<- current + amount
progress$inc(detail = detail, message = title, amount = amount)
if(is.function(log)){
logger(sprintf("[%s]: %s (%d out of %d)", title, detail, round(current), ceiling(max)),
level = 'DEFAULT', bullet = 'arrow_right', .quiet = quiet)
}
}
close <- function(message = 'Finished'){
if(!closed){
progress$close()
closed <<- TRUE
}
}
reset <- function(detail = '', message = '', value = 0){
title <<- message
current <<- value
progress$set(value = value, message = title, detail = detail)
}
# get_value <- function() {
# try({
# re <- progress$getValue()
# if(!length(re) || !is.numeric(re)){
# re <- current
# }
# re
# }, silent = TRUE)
# }
if(shiny_auto_close){
parent_frame <- parent.frame()
do.call(
on.exit, list(substitute(close()), add = TRUE),
envir = parent_frame
)
}
inc(detail = 'Initializing...', amount = 0)
}
return(list(
.progress = progress,
inc = inc,
close = close,
reset = reset,
get_value = get_value,
is_closed = is_closed
))
}
#' @title Progress-bar Handler
#' @description Handler for \code{\link{progress2}} to support
#' \code{progressr::handlers}. See examples for detailed use case
#' @param title default title of \code{\link{progress2}}
#' @param intrusiveness A non-negative scalar on how intrusive
#' (disruptive) the reporter to the user
#' @param target where progression updates are rendered
#' @param enable whether the progress should be reported
#' @param ... passed to \code{\link[progressr]{make_progression_handler}}
#' @examples
#'
#'
#' library(progressr)
#' library(shiny)
#' library(future)
#'
#' ## ------------------------------ Setup! -------------------------------
#' handlers(handler_dipsaus_progress())
#'
#' # ------------------------------ A simple usage ------------------------
#' xs <- 1:5
#' handlers(handler_dipsaus_progress())
#' with_progress({
#' p <- progressor(along = xs)
#' y <- lapply(xs, function(x) {
#' p(sprintf("x=%g", x))
#' Sys.sleep(0.1)
#' sqrt(x)
#' })
#' })
#'
#' # ------------------------ A future.apply case -------------------------
#' plan(sequential)
#' # test it yourself with plan(multisession)
#'
#' handlers(handler_dipsaus_progress())
#' with_progress({
#' p <- progressor(along = xs)
#' y <- future.apply::future_lapply(xs, function(x) {
#' p(sprintf("x=%g", x))
#' Sys.sleep(0.1)
#' sqrt(x)
#' })
#' })
#'
#' # ------------------------ A shiny case --------------------------------
#'
#' ui <- fluidPage(
#' actionButton('ok', 'Run Demo')
#' )
#'
#' server <- function(input, output, session) {
#' handlers(handler_dipsaus_progress())
#' make_forked_clusters()
#'
#' observeEvent(input$ok, {
#' with_progress({
#' p <- progressor(along = 1:100)
#' y <- future.apply::future_lapply(1:100, function(x) {
#' p(sprintf("Input %d|Result %d", x, x+1))
#' Sys.sleep(1)
#' x+1
#' })
#' })
#' })
#' }
#'
#' if(interactive()){
#' shinyApp(ui, server)
#' }
#'
#'
#'
#' @export
handler_dipsaus_progress <- function (
title = getOption("dipsaus.progressr.title", "Progress"),
intrusiveness = getOption("progressr.intrusiveness.gui", 1),
target = if (is.null(shiny::getDefaultReactiveDomain())) "terminal" else "gui",
enable = interactive() || shiny_is_running(),
...)
{
reporter <- local({
pb <- NULL
make_pb <- function(title, max, ...) {
if (!is.null(pb) && !pb$is_closed())
return(pb)
pb <<- progress2(title, max, ..., log = function(...){
msg <- paste(..., sep = '', collapse = ' ')
msg <- gsub(pattern = '[\n]+$', replacement = '', msg)
cw <- getOption('width', 80)
message('\r', paste(rep(' ', cw), collapse = ''), appendLF = FALSE)
message('\r', msg, appendLF = FALSE)
flush.console()
})
pb
}
list(
reset = function(...) {
if(!is.null(pb)){
pb$close()
}
pb <<- NULL
},
initiate = function(config, state, progression, ...) {
if (!state$enabled || config$times == 1L) return()
make_pb(title = title, max = config$max_steps)
},
update = function(config, state, progression, ...) {
if (!state$enabled || config$times <= 2L) return()
# make sure pb exists
make_pb(title = title, max = config$max_steps)
if( state$delta > 0 ){
# message|details
msg <- strsplit(state$message, '|', TRUE)[[1]]
if(length(msg) > 1){
message <- msg[[1]]
detail <- paste(msg[-1], collapse = '|')
}else{
message <- NULL
detail <- state$message
}
pb$inc(message = message, detail = detail,
amount = state$delta)
}
},
finish = function(config, state, progression, ...) {
if( is.null(pb) || pb$is_closed() ) return()
if( pb$get_value() < config$max_steps ){
state$step <- config$max_steps
reporter$update(config = config, state = state,
progression = progression, ...)
}
if (config$clear ) {
# s <- sprintf('%s - Finished', title)
# ss <- paste(rep(' ', nchar(s)), collapse = '')
# cat(sprintf('%s\r%s\n', s, ss))
pb$close(sprintf('%s\r', cli::symbol$square_small_filled))
}
}
)
})
progressr::make_progression_handler(
name = "dipsaus_progress", reporter,
intrusiveness = intrusiveness, enable = enable, ...)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.