###########################################################################/**
# @RdocClass TextStatusBar
#
# @title "A status bar at the R prompt that can be updated"
#
# \description{
# @classhierarchy
#
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{fmt}{A @character format string to be used by @see "base::sprintf".
# Default is a left-aligned string of full width.}
# \item{...}{Named arguments to be passed to @see "base::sprintf" together
# with the format string.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \details{
# A label with name \code{hfill} can be used for automatic horizontal
# filling. It must be @numeric and be immediate before a string
# label such that a \code{hfill} label and the following string label
# together specifies an sprintf format such as \code{"\%*-s"}.
# The value of \code{hfill} will be set such that the resulting status
# bar has width equal to \code{getOption("width")-1} (the reason for the
# -1 is to prevent the text status bar from writing into the next line).
# If more than one \code{hfill} label is used their widths will be
# uniformly distributed. Left over spaces will be distributed between
# \code{hfill} labels with initial values of one.
# }
#
# @examples "../incl/TextStatusBar.Rex"
#
# @author
#
# @keyword programming
# @keyword IO
#*/###########################################################################
setConstructorS3("TextStatusBar", function(fmt=paste("%-", getOption("width")-1, "s", sep=""), ...) {
extend(Object(core=TRUE), "TextStatusBar",
.lastStr = "",
.fmt = fmt,
.args = list(...)
)
})
###########################################################################/**
# @RdocMethod update
#
# @title "Updates the status bar (visually)"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{
# Returns nothing.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("update", "TextStatusBar", function(object, ...) {
# To please R CMD check
this <- object
fmt <- this$.fmt
args <- this$.args
isHFill <- which(names(args) == "hfill")
nHFill <- length(isHFill)
if (nHFill > 0) {
# First, use zero width to figure out the total width without "hfillers".
argsT <- args
argsT[isHFill] <- 0
argsT[isHFill+1] <- ""
str <- do.call(sprintf, args=c(list(fmt=fmt), argsT))
nfill <- (getOption("width")-1) - nchar(str)
if (nfill > 0) {
# Distribute the horizontal fillers evenly.
spcs <- rep(nfill %/% nHFill, times=nHFill)
ndiff <- nfill - sum(spcs)
if (ndiff > 0) {
# For the left overs, distribute them evenly between the hfillers
# with values 1.
incr <- rep(FALSE, times=nHFill)
incr[args[isHFill] == 1] <- TRUE
spcs[incr] <- spcs[incr] + 1
}
args[isHFill] <- spcs
}
}
str <- do.call(sprintf, args=c(list(fmt=fmt), args))
lastStr <- this$.lastStr
this$.lastStr <- str
backspaces <- paste(rep("\b", nchar(lastStr)), collapse="")
cat(backspaces, str, sep="")
})
###########################################################################/**
# @RdocMethod setLabels
#
# @title "Sets new values of given labels"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{A set of named arguments.}
# }
#
# \value{
# Returns nothing.
# }
#
# @author
#
# \seealso{
# @seemethod "setLabel".
# @seemethod "updateLabels".
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("setLabels", "TextStatusBar", function(this, ...) {
pars <- list(...)
args <- this$.args
for (label in names(pars)) {
args[[label]] <- pars[[label]]
}
this$.args <- args
})
###########################################################################/**
# @RdocMethod setLabel
#
# @title "Sets the value of a label"
#
# \description{
# @get "title" address either by its index or its names.
# }
#
# @synopsis
#
# \arguments{
# \item{label}{The index or the name of the label.}
# \item{value}{The value of the label.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns nothing.
# }
#
# @author
#
# \seealso{
# @seemethod "setLabels"
# @seemethod "getLabel"
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("setLabel", "TextStatusBar", function(this, label, value, ...) {
args <- this$.args
args[[label]] <- value
this$.args <- args
})
###########################################################################/**
# @RdocMethod getLabel
#
# @title "Gets the current value of a label"
#
# \description{
# @get "title" address either by its index or its names.
# }
#
# @synopsis
#
# \arguments{
# \item{label}{The index or the name of the label.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns the value.
# }
#
# @author
#
# \seealso{
# @seemethod "setLabel" and @seemethod "setLabels".
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("getLabel", "TextStatusBar", function(this, label, ...) {
args <- this$.args
.subset2(args, label)
})
###########################################################################/**
# @RdocMethod newline
#
# @title "Writes a newline"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{
# Returns nothing.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("newline", "TextStatusBar", function(this, ...) {
this$.lastStr <- ""
cat("\n")
})
###########################################################################/**
# @RdocMethod updateLabels
#
# @title "Sets the new values of given labels and updates the status bar"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{A set of named arguments.}
# }
#
# \value{
# Returns nothing.
# }
#
# @author
#
# \seealso{
# @seemethod "setLabels".
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("updateLabels", "TextStatusBar", function(this, ...) {
setLabels(this, ...)
update(this)
})
###########################################################################/**
# @RdocMethod popMessage
#
# @title "Adds a message above the status bar"
#
# \description{
# @get "title" by scrolling up previous messages popped.
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Arguments passed to @see "base::cat".}
# \item{collapse, sep}{Default values to @see "base::cat".}
# }
#
# \value{
# Returns nothing.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("popMessage", "TextStatusBar", function(this, ..., collapse="", sep="") {
lastStr <- this$.lastStr
# Erase current statusbar
backspaces <- rep("\b", nchar(lastStr))
erazor <- c(backspaces, rep(" ", nchar(lastStr)), backspaces)
cat(erazor, sep="")
this$.lastStr <- ""
cat(..., collapse=collapse, sep=sep)
cat("\n")
update(this)
})
###########################################################################/**
# @RdocMethod flush
#
# @title "Flushes the output"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Arguments passed to @see "base::cat".}
# }
#
# \value{
# Returns nothing.
# }
#
# \details{
# All this methods does is to call @see "utils::flush.console", which
# flushes the output to the console.
# }
#
# @author
#
# \seealso{
# @see "utils::flush.console".
# @seeclass
# }
#
# @keyword programming
#*/###########################################################################
setMethodS3("flush", "TextStatusBar", function(con, ...) {
# To please R CMD check
this <- con
flush.console()
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.