#' Replace null values
#'
#' @param x Value to be tested.
#' @param replacement Value to use if \code{x} is \code{NULL}.
#' @return \code{x} or \code{replacement} in case \code{x} is \code{NULL}.
#' @author Christofer \enc{Bäcklin}{Backlin}
#' @noRd
ifnull <- function(x, replacement=NA) if(is.null(x)) replacement else x
#' Display contents of an evironment, data.frame or list as a summary table
#'
#' Color coded according to class and dimensions of contents. See
#' \code{\link[xtermStyle]{style}} for details.
#'
#' @param envir Environment, data frame or list to be displayed. Optional,
#' default: globalenv()
#' @param pattern Regexp filtering of objects. Only objects matching the pattern
#' are displayed. Optional, default: show all objects.
#' @param all.names Whether to show hidden objects.
#' @param exclude A list of objects not to be displayed. To set a default exclusion
#' mask use the \code{whos.set.mask} function. If \code{whos.set.mask} is
#' called without a list of object names all objects currently in globalenv()
#' are hidden. This is useful for example if you have a lot of stuff in the
#' workspace that you aren't currently interested in but is needed to make
#' your code run.
#' @return Nothing
#' @examples
#' whos()
#' data(USArrests)
#' whos(USArrests)
#'
#' data(iris)
#' whos()
#' whos.all()
#' @author Christofer \enc{Bäcklin}{Backlin}
#' @import data.table
#' @import xtermStyle
#' @seealso whos.options, browse
#' @export
whos <- function(envir=parent.frame(), pattern=".", all.names, exclude=getOpt("exclude")){
# Interpret the `envir` argument if not already an environment
if(is.function(envir)){
envir <- environment(envir)
} else {
envir <- switch(class(envir)[1],
`character` = {
pattern <- envir
parent.frame()
},
`integer` = as.environment(envir),
`numeric` = {
if(envir != as.integer(envir)) stop("Invalid `envir` argument")
as.environment(envir)
},
envir
)
}
# Get names of objects in environment matching pattern
accessors <- if(is.environment(envir)){
if(missing(all.names)){
l <- ls(envir=envir, all.names=FALSE)
if(length(l) == 0)
l <- ls(all.names=TRUE, envir=envir)
} else {
l <- ls(all.names=all.names, envir=envir)
}
structure(l, names=l)
} else if(isS4(envir)){
structure(slotNames(envir), names=slotNames(envir))
} else {
# lists, data.frames, data.tables etc
if(!is.null(names(envir))){
structure(seq_len(length(envir)), names=names(envir))
} else {
1:length(envir)
}
}
if(!is.null(names(accessors))){
accessors <- accessors[!names(accessors) %in% exclude &
grepl(pattern, names(accessors))]
}
if(length(accessors) == 0){
NULL
} else {
obj.sapply <- if(isS4(envir)){
function(fun, ...) sapply(accessors, function(x) ifnull(fun(slot(envir, x))), ...)
} else if(is.character(accessors)){
# Unordered set of objects, as found in an environment
function(fun, ...) sapply(accessors, ..., FUN = function(x){
ifnull(tryCatch(fun(get(x, envir)), error=function(...) NULL))
})
} else {
# Ordered set of objects, as found in a data frame
# Use the index numbers rather than names in case of duplicates
function(fun, ...) sapply(envir, function(x, ...) ifnull(fun(x, ...)), ...)
}
# Make an object/property matrix (objects as rows, properties as columns)
env.cols <- lapply(getOpt("columns")$envir, function(f) f(envir, accessors))
structure(do.call(data.table, c(
list(
style = obj.sapply(style.auto),
name = if(!is.null(names(accessors))) names(accessors) else NA
),
env.cols[!sapply(env.cols, is.null)],
lapply(getOpt("columns")$object, obj.sapply)
)), class=c("whos", "data.table", "data.frame"))
}
}
#' @param x \code{\link{whos}} object.
#' @noRd
#' @export
print.whos <- function(x, ...){
# Remove columns without content
# Always keep the style column, even if no style is used, since it has a special function
x <- x[, c(TRUE, !sapply(x, function(x) all(x %in% c(FALSE, NA)))[-1]), with=FALSE]
# Calculate summaries
xnames <- names(x)
xsum <- mapply(function(field, values){
fun <- ifnull(getOpt("summary")[[field]], function(...) NA)
val2str <- ifnull(getOpt("print")[[field]],
function(x) if(is.na(x)) "" else x)
val2str(fun(values))
}, names(x), x)
# Convert all to characters
x <- matrix(ncol=ncol(x), mapply(function(field, values){
val2str <- getOpt("print")[[field]]
if(is.null(val2str)){
if(is.logical(values)){
ifelse(is.na(values), "", ifelse(values, sprintf("[%s]", field), ""))
} else ifelse(is.na(values), "", as.character(values))
} else val2str(values)
}, names(x), x))
nc <- pmax(nchar(xnames), apply(x, 2, function(x) max(nchar(x))))[-1]
align <- ifelse(getOpt("align")[xnames[-1]] %in% "right", "", "-")
fmt <- paste("%s ", paste(sprintf("%%%s%is", align, nc), collapse=" "), " ", style.clear(), "\n", sep="")
tryCatch({
index.nchar <- ceiling(log10(1+nrow(x)))
# Field names
cat(sprintf(sprintf("%%%is", index.nchar+2), ""),
do.call(sprintf, as.list(c(fmt, "", xnames[-1]))), sep="")
# Content
cat(paste(
sprintf(sprintf("%%%ii: ", index.nchar), seq_len(nrow(x))),
apply(x, 1, function(x) do.call(sprintf, as.list(c(fmt, x)))),
sep="", collapse=""))
# Summary
if(any(xsum != "") && nrow(x) > 1){
cat("Summary:\n",
sprintf(sprintf("%%%is", index.nchar+2), ""),
do.call(sprintf, as.list(c(fmt, xsum))), sep="")
}
}, interrupt=cat(style.clear()))
}
#' Subset a whos object
#'
#' This is exactly the same as the subsetting function of data.table, but
#' preserves the class, to make it find the right print function.
#'
#' @param x \code{\link{whos}} object.
#' @param ... Sent to
#' @noRd
#' @export
`[.whos` <- function(x, ...){
as.whos(as.data.table(x)[...])
}
#' Set default behavior of the whos function
#'
#' @param exclude Objects to exclude from view. Can be a character vector of
#' names, or an environment, but not any regular expressions so far.
#' @param report.S4.size Calculating the size of S4 objects with
#' \code{\link{object.size}} can take an annoyingly long time (seconds), set
#' this option to \code{FALSE} to skip it and get quicker execution.
#' @return Nothing. The values are stored as global options.
#' @author Christofer \enc{Bäcklin}{Backlin}
#' @export
whos.options <- function(exclude, report.S4.size){
if(!missing(exclude)){
options(whos.exclude = switch(class(exclude),
`character` = exclude,
`environment` = ls(exclude),
`integer` = ls(as.environment(exclude))
))
}
if(!missing(report.S4.size))
options(whos.report.S4.size = report.S4.size)
}
#' @param x A character vector of object names to exclude or include.
#' @param pattern \link[=regex]{Regular expression pattern} to match object
#' names against, e.g. \code{pattern="^my\\..*"} will exclude or include
#' \code{"my.vector"} and \code{"my.matrix"} but not \code{"mysql.con"}.
#' @param envir Environment to search in.
#' @rdname whos.options
#' @export
whos.exclude <- function(x=NULL, pattern, envir=parent.frame()){
if(!missing(pattern)) x <- union(x, ls(envir=envir, pattern=pattern))
p <- getOption("dataview")
p$exclude <- union(p$exclude, x)
options(dataview = p)
}
#' @rdname whos.options
#' @export
whos.include <- function(x=NULL, pattern, envir=parent.frame()){
if(!missing(pattern)) x <- union(x, ls(envir=envir, pattern=pattern))
p <- getOption("dataview")
p$exclude <- setdiff(p$exclude, x)
options(dataview = p)
}
#' Shortcut for calling whos without exclusion.
#'
#' @param ... Parameters sent to \code{\link{whos}}.
#' @return Nothing
#' @author Christofer \enc{Bäcklin}{Backlin}
#' @rdname whos
#' @export
whos.all <- function(...){
whos(..., exclude=NULL)
}
#' @param x \code{\link{whos}} object.
#' @param keep.rownames Ignored, kept for S3 consistency.
#' @noRd
#' @export
as.data.table.whos <- function(x, keep.rownames=FALSE){
class(x) <- setdiff(class(x), "whos")
x
}
#' @param x \code{\link{whos}} object.
#' @param optional Ignored, kept for S3 consistency.
#' @param row.names Ignored, kept for S3 consistency.
#' @param ... Ignored, kept for S3 consistency.
#' @noRd
#' @export
as.data.frame.whos <- function(x, row.names=NULL, optional=FALSE, ...){
class(x) <- setdiff(class(x), c("whos", "data.table"))
x
}
#' Convert objects to whos
#'
#' @param x Object of type \code{\link{data.table}} or \code{\link{data.frame}}.
#' @examples
#' an.object <- "Containing all my stuff"
#' w <- as.data.frame(whos())
#' as.whos(w)
#' @author Christofer \enc{Bäcklin}{Backlin}
#' @export
as.whos <- function(x){
UseMethod("as.whos")
}
#' @rdname as.whos
#' @export
as.whos.data.table <- function(x){
class(x) <- c("whos", class(x))
x
}
#' @rdname as.whos
#' @export
as.whos.data.frame <- function(x){
as.whos(as.data.table(x))
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.