## Representation and display
#### show ####
#' Show a unitted object
#'
#' Displays a unitted object, including its units and data type whenever possible
#'
#' @param object the unitted object to display
setMethod(
"show", "unitted",
function(object) {
.unitted_print(object)
}
)
setMethod(
"show", "unitted_NULL",
function(object) {
cat(paste0("unitted ", substring(class(object)[1], 9), " (", get_units(object), ")\n"))
}
)
#### print ####
#' Print a unitted object
#'
#' For many data types, \code{print.unitted} includes the units in its output.
#' For data.frames, for example, it adds a second header row to display the
#' units of each column.
#'
#' @param x The unitted object
#' @param ... other arguments to \code{\link{print}}
#' @return An invisible unitted vector
#' @export
print.unitted <- function(x,...) {
.unitted_print(x, ...)
}
# Print a unitted object
setGeneric(
".unitted_print",
function(x, ...) {
standardGeneric(".unitted_print")
}
)
setMethod(
".unitted_print", "ANY",
function(x, ...) {
cat(paste0("unitted ", substring(class(x)[1], 9), " (", get_units(x), ")\n"))
print(deunitted(x))
}
)
setMethod(
".unitted_print", "NULL",
function(x, ...) {
cat(paste0("unitted NULL (use show() or str() to see units)\n"))
}
)
#' Print a unitted data.frame
#'
#' @rdname print.unitted
#' @inheritParams base::print.data.frame
#' @examples
#' head(u(data.frame(x = u(1:500,"A"), y = u(runif(500),"B"), z = u(500:1,"C"))))
setMethod(
".unitted_print", "data.frame",
function(x, ..., digits = NULL, quote = FALSE, right = TRUE, row.names = TRUE) {
n <- length(row.names(x))
if (length(x) == 0L) {
cat(gettextf("data frame with 0 columns and %d rows\n", n))
}
else if (n == 0L) {
fdf <- deunitted(x)
fdf["U",] <- get_units(x)
m <- as.matrix(fdf)
print(m, ..., quote = quote, right = right)
cat(gettext("<0 rows> (or 0-length row.names)\n"))
}
else {
fdf <- format.data.frame(deunitted(x), digits = digits, na.encode = FALSE)
fdf <- rbind(U=get_units(x),fdf)
m <- as.matrix(fdf)
if (!isTRUE(row.names)) {
dimnames(m)[[1L]] <- if (identical(row.names, FALSE)) {
rep.int("", n)
} else {
row.names
}
}
print(m, ..., quote = quote, right = right)
}
}
)
#' Print a unitted_tbl_df
#'
#' @rdname print.unitted
#' @param n As in tibble's \code{\link[tibble]{formatting}}, Number of rows to
#' show. If `NULL`, the default, will print all rows if less than option
#' `tibble.print_max`. Otherwise, will print `tibble.print_min` rows.
#' @param width As in tibble's \code{\link[tibble]{formatting}}, Width of text
#' output to generate. This defaults to NULL, which means use
#' `getOption("tibble.width")` or (if also NULL) `getOption("width")`; the
#' latter displays only the columns that fit on one screen. You can also set
#' `options(tibble.width = Inf)` to override this default and always print all
#' columns.
#' @param n_extra As in tibble's \code{\link[tibble]{formatting}}, Number of
#' extra columns to print abbreviated information for, if the width is too
#' small for the entire tibble. If `NULL`, the default, will print information
#' about at most `tibble.max_extra_cols` extra columns.
#' @examples
#' tibble::as_tibble(u(list(x = u(1:500,"A"), y = u(runif(500),"B"), z = u(500:1,"C"))))
setMethod(
".unitted_print", "tbl_df",
function(x, ..., n = NULL, width = NULL, n_extra = NULL) {
# shrink table as tibble does
y <- tibble::trunc_mat(v(x), n = n, width = width, n_extra = n_extra)
# insert row for units
y$table <- y$table[c(1,1:nrow(y$table)),]
rownames(y$table)[1:2] <- c("U","")
y$table[1,] <- get_units(x)
# reshrink table in case units are wider than other column contents
yu <- tibble::trunc_mat(y$table, n = n, width = width, n_extra = n_extra)
y$table <- y$table[names(yu$table)]
y[c('extra','width','n_extra')] <- yu[c('extra','width','n_extra')]
# revise the summary vector element name (it's originally 'A tibble')
names(y$summary) <- 'A unitted tibble'
# print
print(y, n=n, width=width, n_extra=n_extra)
invisible(x)
}
)
#### str ####
#' Return the structure of a unitted object.
#'
#' Works like str() but displays units-relevant information more elegantly
#'
#' @name unitted_str
#' @rdname unitted_str
#' @export
#' @importFrom utils str
#' @param object The object whose structure is to be displayed
#' @param ... other arguments passed to \code{str}
str.unitted <- function(object, ...) {
cat(" ",class(object)," (",paste(get_units(object), collapse=";"),"):", sep="")
str(S3Part(object, strictS3=TRUE), ...)
invisible()
}
#' @rdname unitted_str
#' @importFrom utils str
#' @export
str.unitted_data.frame <- function(object, ...) {
if (!is.data.frame(object)) {
warning("str.unitted_data.frame() called with non-data.frame -- coercing to one.")
object <- unitted(data.frame(object))
}
cat("unitted data.frame:\t", nrow(object), " obs. of ", (p <- length(object)),
" variable", if (p != 1)
"s", if (p > 0)
":", "\n", sep = "")
args_say_length <- length(l <- list(...)) && any("give.length" == names(l))
mapply(function(col, colnm) {
cat(" $ ", colnm, ":", sep="")
if(args_say_length)
str(col, ...)
else
str(col, give.length=FALSE, ...)
}, object, names(object))
invisible()
}
#' @rdname unitted_str
#' @export
str.unitted_NULL <- function(object, ...) {
cat(paste0("unitted ", substring(class(object)[1], 9), " (", get_units(object), ")\n"))
invisible()
}
#### .str ####
#' importFrom utils str
#' @rdname dot.str
#' @param object the object to describe
#' @param ... other args for future development
.str <- function(object, ...) {
if(isS4(object)) {
cat("S4 object of class '", class(object), "' (package '", attr(class(object),"package"), "'):\n",sep="")
if(!(".Data" %in% slotNames(class(object)))) {
s3p <- S3Part(object, strictS3=TRUE)
cat("[S3Part]: ")
str(s3p)
}
for(sl in slotNames(class(object))) {
cat("@ ",sl,": ",sep="")
str( slot(object, sl) )
}
} else {
cat("S3 object of oldClass ",paste0(paste0("'", oldClass(object), "'"),collapse=", "),":\n",sep="")
str(object)
}
invisible()
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.