#' Redecorate a List-like Object
#'
#' Redecorates a list-like object.
#' Equivalent to \code{decorate( ..., overwrite = TRUE)}.
#' If \code{meta} is not supplied, an attempt will be made
#' to redecorate with existing decorations, if any.
#'
#' @param x object
#' @param meta file path for corresponding yamlet metadata, or a yamlet object
#' @param ... passed arguments
#' @param overwrite passed to \code{\link{decorate}}
#' @export
#' @keywords internal
#' @family decorate
#' @return a list-like object, typically data.frame
#' @examples
#' library(dplyr)
#' library(magrittr)
#' library(csv)
#' library(haven)
#' file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
#' x <- decorate(as.csv(file))
#' x %>% select(Subject) %>% decorations
#' x %<>% redecorate('Subject: Patient Identifier')
#' x %>% select(Subject) %>% decorations
#'
#' # xpt may already have labels:
#'
#' dm <- 'extdata/dm.xpt.gz' %>%
#' system.file(package = 'yamlet') %>%
#' gzfile %>%
#' read_xpt
#'
#' dm %>% class
#' dm %>% decorations(AGE, SEX, RACE)
#'
#' # but technically not decorated, and poor persistence:
#' bind_rows(dm, dm) %>% decorations(AGE, SEX, RACE)
#'
#' # self-redecorating helps:
#' dm %<>% redecorate
#' bind_rows(dm, dm) %>% decorations(AGE, SEX, RACE)
redecorate <- function(x, meta = NULL, ..., overwrite = TRUE){
if(is.null(meta)){
alt <- try(decorations(x))
if(inherits(alt,'yamlet')) meta <- alt
}
decorate(x, meta = meta, ..., overwrite = overwrite)
}
#' Decorate a List-like Object
#'
#' Decorates a list-like object. Generic.
#' See \code{\link{decorate.character}}.
#' @param x object
#' @param ... passed arguments
#' @export
#' @keywords internal
#' @family decorate
#' @return a list-like object, typically data.frame
#' @examples
#' library(csv)
#' file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
#' x <- decorate(as.csv(file))
#' identical(decorate(as.csv(file)), decorate(file))
#' decorations(x)
#'
#'
decorate <- function(x,...)UseMethod('decorate')
#' Decorate Character
#'
#' Treats \code{x} as a file path. By default,
#' metadata is sought from a file with the same
#' base but the 'yaml' extension.
#'
#' @param x file path for table data
#' @param meta file path for corresponding yamlet metadata, or a yamlet object
#' @param read function or function name for reading x
#' @param ext file extension for metadata file, if relevant
#' @param ... passed to \code{read} (if accepted) and to \code{\link{as_yamlet.character}}
#' @return class 'decorated' 'data.frame'
#' @importFrom csv as.csv
#' @export
#' @family decorate
#' @family interface
#' @examples
#'
#' # find data file
#' file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
#' file
#'
#' # find metadata file
#' meta <- system.file(package = 'yamlet', 'extdata','quinidine.yaml')
#' meta
#'
#' # decorate with explicit metadata reference
#' a <- decorate(file, meta)
#'
#' # rely on default metadata path
#' b <- decorate(file)
#'
#' # in this case: same
#' stopifnot(identical(a, b))
decorate.character <- function(
x,
meta = NULL,
...,
read = getOption('yamlet_import', as.csv),
ext = getOption('yamlet_extension', '.yaml')
# coerce = getOption('yamlet_coerce',FALSE),
){
stopifnot(length(x) == 1)
if(!file.exists(x))stop('could not find file ', x)
read <- match.fun(read)
args <- list(...)
# args <- args[names(args) %in% names(formals(read))] # debilitating
args <- c(list(x),args)
y <- do.call(read, args)
if(is.null(meta)){
meta <- sub('\\.[^.]*$','',x) # remove last dot and any trailing chars
meta <- paste0(meta, ext)
}
if(is.character(meta) & length(meta) == 1){
meta <- try(as_yamlet(meta,...))
}
if(!inherits(meta, 'yamlet')) stop('could not interpret meta: ', meta)
decorate(
y,
meta = meta,
# coerce = coerce,
...
)
}
#' Decorate List
#'
#' Decorates a list-like object. Takes metadata
#' in yamlet format and loads it onto corresponding
#' list elements as attributes.
#'
#' As of v0.8.8, attribute persistence is supported
#' by optionally coercing decorated items to class 'dvec'
#' where suitable methods exist. \code{persistence}
#' is false by default for the list method
#' but true by default for the data.frame method.
#' See also \code{\link{decorate.data.frame}}.
#'
#' @param x object inheriting from \code{list}
#' @param meta file path for corresponding yaml metadata, or a yamlet or something coercible to yamlet; an attempt will be made to guess the file path if x has a 'source' attribute (as for \code{\link[csv]{as.csv}})
#' @param ... passed to \code{\link{as_yamlet.character}} (by method dispatch)
#' @param ext file extension for metadata file, if relevant
#' @param persistence whether to coerce decorated items to 'dvec' where suitable method exists
#' @param overwrite whether to overwrite attributes that are already present (else give warning)
#' @return like x but with 'decorated' as first class element
#' @export
#' @keywords internal
#' @family decorate
#' @examples
#' example(decorate.data.frame)
#'
decorate.list <- function(
x,
meta = NULL,
...,
ext = getOption('yamlet_extension', '.yaml'),
persistence = getOption('yamlet_persistence', FALSE),
overwrite = getOption('yamlet_overwrite', FALSE)
){
if(is.null(meta)) meta <- attr(x, 'source')
if(is.null(meta)) stop('could not guess metadata location; supply meta')
m <- try(silent = TRUE, as_yamlet(meta))
if(inherits(m, 'yamlet')) meta <- m
if(is.character(meta) & length(meta) == 1){
meta <- sub('\\.[^.]*$','',meta) # remove last dot and any trailing chars
meta <- paste0(meta, ext)
meta <- try(as_yamlet(meta, ...))
}
if(!inherits(meta, 'yamlet')) stop('could not interpret meta: ', meta)
for(item in names(x)){ # if list has no names, nothing happens
if(item %in% names(meta)){ # if list has names, name '' should not be reached
val <- meta[[item]]
for(attrb in names(val)){
if(attrb == ''){ # warn if name is ''
warning('ignoring anonymous attribute for ', item)
next
}
if(attrb %in% names(attributes(x[[item]]))){
if(!overwrite){
if(
!identical( # avoid moot warnings
attr(x[[item]], attrb), # current
val[[attrb]] # proposed
)
){
warning('not overwriting ', attrb, ' attribute of ', item)
}
next # avoid all overwrites, moot or otherwise
}
}
attr(x[[item]], attrb) <- val[[attrb]]
# since this is really the only place we
# assign an attribute, it is a good place
# to coerce to dvec. A bit redundant
# if more than one attribute,
# but safer and perhaps not too expensive.
if(persistence){
try(silent = TRUE, x[[item]] <- as_dvec(x[[item]]))
}
}
}
}
# as of 0.6.2, this is the only constructor for 'decorated'
class(x) <- union('decorated', class(x))
x
}
#' Decorate Data Frame
#'
#' Decorates a data.frame. Expects metadata in yamlet
#' format, and loads it onto columns as attributes.
#'
#' As of v0.8.8, the data.frame method for decorate()
#' coerces affected columns using \code{\link{as_dvec}}
#' if \code{persistence} is true and a suitable method
#' exists. 'vctrs' methods are implemented for class
#' \code{dvec} to help attributes persist during
#' tidyverse operations. Details are described in
#' \code{\link{c.dvec}}. Disable this functionality
#' with \code{options(yamlet_persistence = FALSE)}.
#' @param x data.frame
#' @param meta file path for corresponding yaml metadata, or a yamlet; an attempt will be made to guess the file path if x has a 'source' attribute
#' @param ... passed to \code{\link{decorate.list}}
#' @param persistence whether to coerce decorated columns to 'dvec' where suitable method exists
#' @return class 'decorated' 'data.frame'
#' @export
#' @family interface
#' @family decorate
#' @seealso decorate.list
#' @examples
#'
#' # find data path
#' library(csv)
#' file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
#' file
#' dat <- as.csv(file) # dat now has 'source' attribute
#'
#' # use source attribute to find metadata
#' a <- decorate(as.csv(file))
#'
#' # supply metadata path (or something close) explicitly
#' b <- decorate(dat, meta = file)
#'
#' # these are equivalent
#' stopifnot(identical(a, b))
decorate.data.frame <- function(
x,
meta = NULL,
...,
persistence = getOption('yamlet_persistence', TRUE)
)decorate.list(
x,
meta = meta,
...,
persistence = persistence
)
#' Retrieve Decorations
#'
#' Retrieve the decorations of something.
#' Generic, with method \code{\link{decorations.data.frame}}.
#'
#' @param x object
#' @param ... passed arguments
#' @export
#' @keywords internal
#' @family decorate
#' @return see methods
#' @examples
#' library(csv)
#' file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
#' x <- decorate(as.csv(file))
#' decorations(x)
decorations <- function(x,...)UseMethod('decorations')
#' Retrieve Decorations for Data Frame
#'
#' Retrieve the decorations of a data.frame; i.e., the metadata
#' used to decorate it. Returns a list with same names as the data.frame.
#' By default, 'class' and 'level' attributes are excluded from the result,
#' as you likely don't want to manipulate these independently.
# As of 0.6.1, dropping coerce argument because of conflicts with classified().
# former help:
# Consider carefully whether the default handling of factor levels
# (see \code{coerce} argument) is appropriate for your application.
#'
#' @param x data.frame
#' @param ... optional unquoted column names to limit output (passed to \code{\link[dplyr]{select}})
# @param coerce logical: whether to coerce factor levels to guide; alternatively, a key for the levels
#' @param exclude_attr attributes to remove from the result
#' @export
#' @family decorate
#' @return named list of class 'yamlet'
#' @examples
#' # prepare a decorated data.frame
#' file <- system.file(package = 'yamlet', 'extdata','quinidine.csv')
#' x <- decorate(file)
#'
#' # retrieve the decorations
#' decorations(x, Subject, time, conc)
decorations.data.frame <- function(
x,
...,
# coerce = getOption('yamlet_coerce_decorations', FALSE),
exclude_attr = getOption('yamlet_exclude_attr', c('class','levels'))
# and possibly comment, dim, dimnames, names, row.names, and tsp
# see help for attributes
){
# coerce <- FALSE
stopifnot(length(exclude_attr) == 0 || is.character(exclude_attr))
nms <- selected(x, ...)
x <- x[, as.character(nms), drop = FALSE] # selected may have incompatible class path
out <- lapply(x, attributes)
levs_key <- 'guide'
# if(!is.logical(coerce)){
# if(is.character(coerce))
# if(length(coerce) == 1){
# levs_key <- coerce
# coerce <- TRUE
# }
# }
# if(!is.logical(coerce)){
# warning('coerce value not logical')
# }else{
# if(coerce){
# for(i in seq_along(out)){
# if('class' %in% names(out[[i]])){
# if(any(out[[i]]$class == 'factor')){ # factor or ordered factor
# out[[i]]$class <- NULL
# names(out[[i]])[names(out[[i]]) == 'levels'] <- levs_key
# }
# }
# }
# }
# }
for(i in exclude_attr){
for(j in names(out)){
if(i %in% names(out[[j]])) out[[j]][[i]] <- NULL
}
}
class(out) <- 'yamlet'
out
}
# Print Decorations
#
# Prints decorations. Coerces to yamlet and prints result.
#
# @param x decorations, i.e. a named list of class 'decorations'
# @param ... ignored
# @export
# @family decorate
# @keywords internal
# @return invisible x (yamlet)
# @examples
# example(decorations.data.frame)
# print.decorations <- function(x, ...){
# x <- as_yamlet(x)
# print(x)
# }
# there is no actual class 'decorations' so methods unnecessary at 0.6.2.
#' Coerce to Decorated
#'
#' Coerces to class 'decorated'. Generic, with method \code{\link{as_decorated.default}}.
#'
#' @param x object
#' @param ... passed arguments
#' @export
#' @family decorate
#' @keywords internal
#' @return decorated
#' @examples
#' class(Puromycin)
#' class(as_decorated(Puromycin))
as_decorated <- function(x, ...)UseMethod('as_decorated')
#' Coerce to Decorated by Default
#'
#' Coerces to class 'decorated' by decorating (by default) with an empty list.
#'
#' @param x object
#' @param meta see \code{\link{decorate.list}}
#' @param ... passed arguments
#' @export
#' @keywords internal
#' @family decorate
#' @return decorated
#' @examples
#' class(Puromycin)
#' class(as_decorated(Puromycin))
as_decorated.default <- function(x, meta = '-', ...){
decorate(x, meta = meta, ...)
}
# @aliases decorations.data.frame
# @keywords internal
#decorations.data.frame
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.