#' Create sources for dsinfo
#'
#' A source can (for example) be a file system path or a person with an email
#' address. `dsi_source()` is a constructor for a signle `dsinfo_source`, while
#' `dsi_sources()` is a list of such sources. In addition to the recommendations
#' of the [data package](https://frictionlessdata.io/data-package/) standard
#' `dsinfo` sources can also have a `date`.
#'
#' @param title `character` scalar. Title of the source
#' @param path `character` vector. Path(s) to the source
#' @param email `character` vector. Email address(es) of the source
#' @param date vector. Date of the source; usually [POSIXct] or [Date] but any
#' atomic \R vector is accepted.
#'
#' @return `dsi_source()` returns a `dsinfo_source` object.
#' @export
#'
#' @seealso [sources()] for an alternative way to get and set sources
#' @examples
#' person <- dsi_source("blubb", "blah@@blubb.at")
#' files <- dsi_sources_from_paths(c(tempfile(), tempfile(), tempfile()))
#' src <- dsi_sources(person, files)
#'
#' x <- set_dsinfo(
#' iris,
#' title = "Iris",
#' sources = src
#' )
#'
#' dsinfo(x)
dsi_source <- function(title, path = NULL, email = NULL, date = NULL){
assert(is_scalar_character(title))
assert(is.null(path) || is_scalar_character(path))
assert(is.null(email) || is.character(email))
assert(is.null(date) || is.atomic(date))
res <- list(title = title, path = path, email = email, date = date)
attr(res, "class") <- c("dsinfo_source", "list")
res
}
#' `dsi_sources()` and `dsi_sources_list()` are constructors for objects that
#' can be used for the `source` parameter of [dsinfo()] (a list of sources)
#'
#' @param ... `dsinfo_source` or other `dsinfo_sources` objects.
#' @export
#' @return `dsi_sources()`, `dsi_sources_list()`, and `dsi_sources_from_paths()`
#' return a `dsinfo_sources` object, which is a list of `dsinfo_source`
#' objects.
#' @rdname dsi_source
#'
dsi_sources <- function(...){
dsi_sources_list(list(...))
}
#' @param sources a list of `dsinfo_source` objects.
#' @export
#' @rdname dsi_source
dsi_sources_list <- function(sources){
sel1 <- vapply(sources, is_dsinfo_source, FALSE)
sel2 <- vapply(sources, is_dsinfo_sources, FALSE)
stopifnot(all(sel1 | sel2))
res <- c(sources[sel1], unlist(sources[sel2], recursive = FALSE))
attr(res, "class") <- c("dsinfo_sources", "list")
res
}
#' `dsi_sources_from_paths()` is a helper function to automatically creates a
#' `dsi_sources` object from file system paths.
#'
#' @param paths `character` vector of file system paths
#' @return `dsi_sources_from_paths` returns a `dsi_sources` object.
#' @rdname dsi_source
#' @export
dsi_sources_from_paths <- function(paths, email = NULL){
dsi_sources_list(
lapply(paths, function(x){
dsi_source(title = basename(x), path = x, date = file.info(x)$mtime, email = email)
})
)
}
#' Get or set dsinfo sources of R objects
#'
#' `sources()` and `sources<-()` provide a direct way to get and set the
#' `$sources` field of a `dsinfo` attribute.
#'
#' @param ... usually \R objects with [dsinfo] attributes, Can also handle
#' `dsinfo` objects, [dsi_sources], or [dsi_source] objects directly.
#' @param list a `list` of \R objects like `...`. Will be combined
#' with `...` if both are provided.
#' @param consolidate `logical` scalar. If `TRUE` remove duplicated sources
#' from the output
#'
#' @seealso [dsi_source()] for more info on `dsinfo_sources` objects.
#' @return a [dsinfo_sources] object
#' @export
#' @examples
#' x <- iris
#' sources(x) <- dsi_source(
#' "Fisher, R. A.: The use of multiple measurements in taxonomic problems",
#' path = "https://doi.org/10.1111/j.1469-1809.1936.tb02137.x",
#' date = 1936
#' )
#' sources(x)
#' # can also be used directly on dsinfo or dsi_source(s) objects.
#' y <- dsinfo(x)
#' z <- dsi_source("a dsi_source object")
#' sources(x, y, z)
#' sources(x, y, z, consolidate = TRUE)
sources <- function(
...,
list = NULL,
consolidate = FALSE
){
assert(is_scalar_bool(consolidate))
l <- c(list(...), list)
src <- lapply(l, function(.){
if (is_dsinfo_sources(.))
.
else if (is_dsinfo_source(.)){
dsi_sources(.)
} else if (inherits(., "dsinfo")) {
.$sources
} else {
dsinfo(.)$sources
}
})
src <- dsi_sources_list(compact(src))
if (consolidate)
consolidate_sources(src)
else
src
}
#' @param value Value to assign.
#' @rdname sources
#' @export
`sources<-` <- function(x, value){
assert(
is_dsinfo_source(value) || is_dsinfo_sources(value),
"expected a `dsi_sources` or `dsi_source` objec, not ", preview_object(value)
)
dsi <- dsinfo(x)
if (inherits(dsi, "dsinfo")){
dsi$sources <- value
attr(x, "dsinfo") <- dsi
} else {
x <- set_dsinfo(x, sources = value)
}
x
}
# printing ----------------------------------------------------------------
#' @export
print.dsinfo_source <- function(x, ...){
cat(format(x), sep = "\n")
invisible(x)
}
#' @export
print.dsinfo_sources <- function(x, ...){
cat(format(x), sep = "\n")
invisible(x)
}
#' @export
format.dsinfo_sources <- function(x, ...){
unlist(lapply(x, format))
}
#' @export
format.dsinfo_source <- function(
x,
...
){
if (!is.null(x$date)){
title <- paste(
x$title,
style_subtle(paste0("(", format(x$date), ")"))
)
} else {
title <- x$title
}
paths <- vapply(
x$path,
function(x.) style_subtle(paste(" -", x.)),
""
)
emails <- vapply(
x$email,
function(x.) style_subtle(paste(" -", x.)),
""
)
if (!is_empty(emails)) emails <- paste(emails)
c(title, paths, emails)
}
# is ----------------------------------------------------------------------
is_dsinfo_source <- function(x){
inherits(x, "dsinfo_source")
}
is_dsinfo_sources <- function(x){
inherits(x, "dsinfo_sources")
}
# utils -------------------------------------------------------------------
consolidate_sources <- function(
x
){
assert(is_dsinfo_sources(x))
res <- vector("list", length(x))
for (i in seq_along(x)){
for (j in seq_along(x)){
a <- x[[i]]
b <- x[[j]]
if (
!identical(i, j) &&
identical(a$title, b$title) &&
identical(a$path, b$path) &&
identical(a$email, b$email) &&
identical(a$date, b$date)
){
x[j] <- list(NULL)
}
}
}
res <- compact(x)
res <- res[order(vapply(res, `[[`, character(1), "title"))]
dsi_sources_list(res)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.