R/util.R
In USGS-VIZLAB/vizlab: Utilities for building online data visualizations
Defines functions
checkRequired
relativePath
buildContext
expandDependencies
gatherDependencyList
lookupMimetype
getPartialLibrary
handleMarkdown
setupFoldersForFile
uniqueness
replaceOrAppend
getVizURL
pastePaths
Documented in
buildContext
checkRequired
expandDependencies
gatherDependencyList
getPartialLibrary
handleMarkdown
lookupMimetype
relativePath
replaceOrAppend
setupFoldersForFile
uniqueness
### Utility functions for use in vizlab ###
#' Check required fields
#'
#' @param x object to check for fields
#' @param required list of fields required
#' @export
checkRequired <- function(x, required) {
hasAll <- all(required %in% names(x))
if (!hasAll) {
stop(x[['id']], " missing at least one of ", paste(required, collapse = ", "))
}
}
#' Get webapp path
#'
#' @param file path to file being exported
#' @return character vector describing relative path
#' @export
relativePath <- function(file) {
exportAndPath <- sub(exportLocation(), "", file)
return(exportAndPath)
}
#' Build context for templating
#'
#' @param context context list
#' @param dependencies list of dependency ids
#' @return list of context with dependencies injected
buildContext <- function(context, dependencies) {
# allow for context to be inline
data <- context
if (is.null(data)) {
data <- list()
} else if (is.character(data)) {
data <- readData(data)
}
# replace dependencies (context names) with contents (usually html tags for
# script, link, etc.)
data <- rapply(data, function(x) {
dep.ids <- x %in% names(dependencies)
if (any(dep.ids)) {
x[which(dep.ids)] <- dependencies[x[which(dep.ids)]]
}
return(x)
}, how = "replace", classes = "character")
return(data)
}
#' Private function to publish a dependency. Returns either the output of
#' publish or the result of readData on the output of publish
#'
#' Cases when you'd want to return the output of publish(): dependency x is a
#' javascript library or css file to be referenced in a <script> or <link> tag
#' in <head>
#'
#' Cases when you'd want to return the output of readData(publish()): when the
#' context for rendering a mustache template includes named viz items whose
#' contents we want to include. For example: a page section's template has a
#' {{{text-before}}} field, and the context for that section includes
#' `text-before: page_text.section3_text_before`, and section3_text_before is a
#' named item in page_text.yaml.
#'
#' @param x item to expand
expandDependencies <- function(x) {
expanded.dep <- publish(x)
if (is.list(expanded.dep) && !is.null(expanded.dep[['reader']])) {
expanded.dep <- as.reader(expanded.dep)
expanded.dep <- readData(expanded.dep)
}
return(expanded.dep)
}
#' Pull together vizlab object dependencies
#'
#' @param ... dependencies to gather
gatherDependencyList <- function(...) {
dependencies <- list()
depNames <- list()
# add automatic dependencies
deps <- as.list(...)
for (i in seq_along(deps)) {
if (!is.null(deps[i])) {
dependencies <- append(dependencies, deps[i])
if (is.null(names(deps)[i]) || names(deps)[i] == "") {
depNames <- append(depNames, deps[i])
} else {
depNames <- append(depNames, names(deps)[i])
}
}
}
# TODO Watch out for cyclic depends
names(dependencies) <- depNames
dependencies <- lapply(dependencies, expandDependencies)
return(dependencies)
}
#' Use mimetype lookup to get reader
#'
#' @importFrom utils modifyList
#' @param mimetype character vector of length one with the mimetype name
#' @return character vector describing the reader to be used
#' @importFrom utils modifyList
#' @export
lookupMimetype <- function(mimetype){
# add to and replace default mimetypes using the file specified in viz.yaml
mimetype_list_default <- yaml.load_file(system.file('mimetypes.default.yaml', package="vizlab"))
mimetype_file_user <- getBlocks('info')[[1]]$mimetypeDictionary[[1]]
if(length(mimetype_file_user) != 0){
mimetype_list_user <- yaml.load_file(mimetype_file_user)
} else {
mimetype_list_user <- list()
}
mimetype_list <- modifyList(mimetype_list_default, mimetype_list_user)
# match the current mimetype with one in the list to get the correct reader/publisher
type_match <- which(unlist(lapply(mimetype_list,
FUN=function(mimetype_list, mimetype){
mimetype %in% mimetype_list},
mimetype=mimetype)))
type_nm <- names(type_match)
return(type_nm)
}
#' Assemble whisker partials from vizlab package
#'
#' @importFrom tools file_path_sans_ext
#' @return list containing partials available
getPartialLibrary <- function() {
template.dir <- system.file("templates", package = "vizlab")
template.files <- dir(template.dir, pattern = "*.mustache")
template.names <- file_path_sans_ext(template.files)
partials <- lapply(template.files, function(x, dir) {
viz <- list(
location = file.path(dir, x),
reader = "txt"
)
viz <- as.reader(as.viz(viz))
return(readData(viz))
}, template.dir)
names(partials) <- template.names
return(partials)
}
#' Internal function to get shared resources
#' Implemented as a closure to avoid reloading file each time
#'
#' @param x character vector containing resource id
#' @param no.match what to do if the viz.id is not found: either 'stop' (throw
#' error) or 'NA' (return NA)
#' @importFrom yaml yaml.load_file
#' @importFrom utils packageName
#' @return vizlab object from library or \code{NULL} if it doesn't exist
getResourceFromLibrary <- (function() {
resources <- yaml.load_file(system.file("resource.library.yaml", package=packageName()))
names(resources) <- lapply(resources, function(r) { r[['id']] })
return(function(x, no.match = c("stop", "NA")) {
viz <- resources[[x]]
if (!is.null(viz)) {
viz <- as.viz(viz)
resource.file <- system.file(viz[['location']], package=packageName())
# convert to absolute if exists
if (file.exists(resource.file)) {
viz[['location']] <- resource.file
}
} else {
viz <- match(no.match, c("NA" = NA, "stop" = stop("Could not find ", x)))
}
return(viz)
})
})()
#' Replace any markdown text with rendered html
#'
#' @importFrom markdown markdownToHTML
#' @param text character vector containing markdown text
handleMarkdown <- function(text) {
options <- c("skip_html", "skip_style", "skip_images", "escape", "smartypants", "fragment_only")
extensions <- c("tables", "fenced_code", "strikethrough", "lax_spacing", "superscript", "latex_math")
html <- markdownToHTML(text = text, options = options, extensions = extensions)
m <- regexec("^<p>(.*)</p>\\n$", html, perl = TRUE)
if (length(regmatches(x = html, m = m)[[1]]) > 0) {
# capture the stuff between paragraph tags (group 1, index 2)
html <- regmatches(x = html, m = m)[[1]][2]
}
return(html)
}
#' Sets up folders so file can be written without warnings
#'
#' @param file file that is about to be written
#' @export
setupFoldersForFile <- function(file) {
dir <- dirname(file)
dir.create(dir, recursive = TRUE, showWarnings = FALSE)
}
#' Grab a random number to break the cache
#' @importFrom stats runif
#' @return random number between 10000 and 10000000
uniqueness <- function() {
rng <- floor(runif(n = 1, min = 10000, max = 10000000))
return(rng)
}
#' Append second list to first with overwrites
#'
#' @param x list template to be filled by values of another list
#' @param y list to overwrite missing values or append to first list
#' @return list containing merged values from both x and y
replaceOrAppend <- function(x, y) {
slots <- unique(c(names(x), names(y)))
out <- list()
for (slot in slots) {
if (is.list(x[[slot]])) {
# append
out[[slot]] <- append(x[[slot]], y[[slot]])
} else {
if(!is.null(y[[slot]])) {
# replace
out[[slot]] <- y[[slot]]
} else {
# retain
out[[slot]] <- x[[slot]]
}
}
}
return(out)
}
getVizURL <- function() {
baseURL <- vizlab.pkg.env$baseURL
path <- getBlocks("info")$info$path[[1]]
return(pastePaths(baseURL, path))
}
#smart paste paths/URLs together with or without slashes included
#doesn't handle NA or nulls
pastePaths <- function(str1, str2) {
if (substring(str1, nchar(str1)) == "/" || substring(str2, 1,1) == "/") {
ret <- paste0(str1, str2)
} else {
ret <- paste(str1, str2, sep = "/")
}
return(ret)
}
USGS-VIZLAB/vizlab documentation built on July 10, 2019, 12:08 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions checkRequired relativePath buildContext expandDependencies gatherDependencyList lookupMimetype getPartialLibrary handleMarkdown setupFoldersForFile uniqueness replaceOrAppend getVizURL pastePaths
Documented in buildContext checkRequired expandDependencies gatherDependencyList getPartialLibrary handleMarkdown lookupMimetype relativePath replaceOrAppend setupFoldersForFile uniqueness
### Utility functions for use in vizlab ###
#' Check required fields
#'
#' @param x object to check for fields
#' @param required list of fields required
#' @export
checkRequired <- function(x, required) {
hasAll <- all(required %in% names(x))
if (!hasAll) {
stop(x[['id']], " missing at least one of ", paste(required, collapse = ", "))
}
}
#' Get webapp path
#'
#' @param file path to file being exported
#' @return character vector describing relative path
#' @export
relativePath <- function(file) {
exportAndPath <- sub(exportLocation(), "", file)
return(exportAndPath)
}
#' Build context for templating
#'
#' @param context context list
#' @param dependencies list of dependency ids
#' @return list of context with dependencies injected
buildContext <- function(context, dependencies) {
# allow for context to be inline
data <- context
if (is.null(data)) {
data <- list()
} else if (is.character(data)) {
data <- readData(data)
}
# replace dependencies (context names) with contents (usually html tags for
# script, link, etc.)
data <- rapply(data, function(x) {
dep.ids <- x %in% names(dependencies)
if (any(dep.ids)) {
x[which(dep.ids)] <- dependencies[x[which(dep.ids)]]
}
return(x)
}, how = "replace", classes = "character")
return(data)
}
#' Private function to publish a dependency. Returns either the output of
#' publish or the result of readData on the output of publish
#'
#' Cases when you'd want to return the output of publish(): dependency x is a
#' javascript library or css file to be referenced in a <script> or <link> tag
#' in <head>
#'
#' Cases when you'd want to return the output of readData(publish()): when the
#' context for rendering a mustache template includes named viz items whose
#' contents we want to include. For example: a page section's template has a
#' {{{text-before}}} field, and the context for that section includes
#' `text-before: page_text.section3_text_before`, and section3_text_before is a
#' named item in page_text.yaml.
#'
#' @param x item to expand
expandDependencies <- function(x) {
expanded.dep <- publish(x)
if (is.list(expanded.dep) && !is.null(expanded.dep[['reader']])) {
expanded.dep <- as.reader(expanded.dep)
expanded.dep <- readData(expanded.dep)
}
return(expanded.dep)
}
#' Pull together vizlab object dependencies
#'
#' @param ... dependencies to gather
gatherDependencyList <- function(...) {
dependencies <- list()
depNames <- list()
# add automatic dependencies
deps <- as.list(...)
for (i in seq_along(deps)) {
if (!is.null(deps[i])) {
dependencies <- append(dependencies, deps[i])
if (is.null(names(deps)[i]) || names(deps)[i] == "") {
depNames <- append(depNames, deps[i])
} else {
depNames <- append(depNames, names(deps)[i])
}
}
}
# TODO Watch out for cyclic depends
names(dependencies) <- depNames
dependencies <- lapply(dependencies, expandDependencies)
return(dependencies)
}
#' Use mimetype lookup to get reader
#'
#' @importFrom utils modifyList
#' @param mimetype character vector of length one with the mimetype name
#' @return character vector describing the reader to be used
#' @importFrom utils modifyList
#' @export
lookupMimetype <- function(mimetype){
# add to and replace default mimetypes using the file specified in viz.yaml
mimetype_list_default <- yaml.load_file(system.file('mimetypes.default.yaml', package="vizlab"))
mimetype_file_user <- getBlocks('info')[[1]]$mimetypeDictionary[[1]]
if(length(mimetype_file_user) != 0){
mimetype_list_user <- yaml.load_file(mimetype_file_user)
} else {
mimetype_list_user <- list()
}
mimetype_list <- modifyList(mimetype_list_default, mimetype_list_user)
# match the current mimetype with one in the list to get the correct reader/publisher
type_match <- which(unlist(lapply(mimetype_list,
FUN=function(mimetype_list, mimetype){
mimetype %in% mimetype_list},
mimetype=mimetype)))
type_nm <- names(type_match)
return(type_nm)
}
#' Assemble whisker partials from vizlab package
#'
#' @importFrom tools file_path_sans_ext
#' @return list containing partials available
getPartialLibrary <- function() {
template.dir <- system.file("templates", package = "vizlab")
template.files <- dir(template.dir, pattern = "*.mustache")
template.names <- file_path_sans_ext(template.files)
partials <- lapply(template.files, function(x, dir) {
viz <- list(
location = file.path(dir, x),
reader = "txt"
)
viz <- as.reader(as.viz(viz))
return(readData(viz))
}, template.dir)
names(partials) <- template.names
return(partials)
}
#' Internal function to get shared resources
#' Implemented as a closure to avoid reloading file each time
#'
#' @param x character vector containing resource id
#' @param no.match what to do if the viz.id is not found: either 'stop' (throw
#' error) or 'NA' (return NA)
#' @importFrom yaml yaml.load_file
#' @importFrom utils packageName
#' @return vizlab object from library or \code{NULL} if it doesn't exist
getResourceFromLibrary <- (function() {
resources <- yaml.load_file(system.file("resource.library.yaml", package=packageName()))
names(resources) <- lapply(resources, function(r) { r[['id']] })
return(function(x, no.match = c("stop", "NA")) {
viz <- resources[[x]]
if (!is.null(viz)) {
viz <- as.viz(viz)
resource.file <- system.file(viz[['location']], package=packageName())
# convert to absolute if exists
if (file.exists(resource.file)) {
viz[['location']] <- resource.file
}
} else {
viz <- match(no.match, c("NA" = NA, "stop" = stop("Could not find ", x)))
}
return(viz)
})
})()
#' Replace any markdown text with rendered html
#'
#' @importFrom markdown markdownToHTML
#' @param text character vector containing markdown text
handleMarkdown <- function(text) {
options <- c("skip_html", "skip_style", "skip_images", "escape", "smartypants", "fragment_only")
extensions <- c("tables", "fenced_code", "strikethrough", "lax_spacing", "superscript", "latex_math")
html <- markdownToHTML(text = text, options = options, extensions = extensions)
m <- regexec("^<p>(.*)</p>\\n$", html, perl = TRUE)
if (length(regmatches(x = html, m = m)[[1]]) > 0) {
# capture the stuff between paragraph tags (group 1, index 2)
html <- regmatches(x = html, m = m)[[1]][2]
}
return(html)
}
#' Sets up folders so file can be written without warnings
#'
#' @param file file that is about to be written
#' @export
setupFoldersForFile <- function(file) {
dir <- dirname(file)
dir.create(dir, recursive = TRUE, showWarnings = FALSE)
}
#' Grab a random number to break the cache
#' @importFrom stats runif
#' @return random number between 10000 and 10000000
uniqueness <- function() {
rng <- floor(runif(n = 1, min = 10000, max = 10000000))
return(rng)
}
#' Append second list to first with overwrites
#'
#' @param x list template to be filled by values of another list
#' @param y list to overwrite missing values or append to first list
#' @return list containing merged values from both x and y
replaceOrAppend <- function(x, y) {
slots <- unique(c(names(x), names(y)))
out <- list()
for (slot in slots) {
if (is.list(x[[slot]])) {
# append
out[[slot]] <- append(x[[slot]], y[[slot]])
} else {
if(!is.null(y[[slot]])) {
# replace
out[[slot]] <- y[[slot]]
} else {
# retain
out[[slot]] <- x[[slot]]
}
}
}
return(out)
}
getVizURL <- function() {
baseURL <- vizlab.pkg.env$baseURL
path <- getBlocks("info")$info$path[[1]]
return(pastePaths(baseURL, path))
}
#smart paste paths/URLs together with or without slashes included
#doesn't handle NA or nulls
pastePaths <- function(str1, str2) {
if (substring(str1, nchar(str1)) == "/" || substring(str2, 1,1) == "/") {
ret <- paste0(str1, str2)
} else {
ret <- paste(str1, str2, sep = "/")
}
return(ret)
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.