Nothing
#' 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
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.