Nothing
#' Make a CrunchBox
#'
#' CrunchBoxes allow you to publish results to the world.
#'
#' In addition to specifying the variables and filters to include in your
#' CrunchBox, you can provide custom color palettes. The arguments
#' `brand_colors`, `static_colors`, and `category_color_lookup` allow you to
#' provide color lists to use. Colors should be either a valid hexadecimal
#' string representation, like "#fa1af1", or they may also be an R named color,
#' such as "darkgreen".
#'
#' @param dataset A CrunchDataset, potentially a selection of variables from it
#' @param filters FilterCatalog, or `NULL` for no filters. Default all
#' filters in your catalog, `filters(dataset)`.
#' @param weight a CrunchVariable that has been designated as a potential
#' weight variable for `dataset`, or `NULL` for unweighted results.
#' Default is the currently applied [`weight()`].
#' @param brand_colors an optional color vector of length 3 or less, or a named
#' list with names 'primary', 'secondary', and 'message'. See "Details" for more
#' about color specification.
#' @param static_colors an optional vector of colors to use for categorical
#' plots. Bars and lines are colored in the order of `static_colors`. See
#' "Details" for more about color specification.
#' @param category_color_lookup an optional list of category names to colors
#' to use for that category, wherever it appears in the data. This allows you
#' to always see a category displayed in a specific color. See
#' "Details" for more about color specification.
#' @param ... additional metadata for the box, such as "title", "header", etc.
#' @return The URL to the newly created box.
#'
#' @examples
#'
#' \dontrun{
#' # Creating a CrunchBox with three variables
#' crunchBox(ds[c("var1", "var2", "var3")], title = "New CrunchBox")
#'
#' # Creating a CrunchBox changing primary, secondary, and message brand colors
#' crunchBox(ds[c("var1", "var2", "var3")],
#' title = "Branded CrunchBox",
#' brand_colors = c("#ff0aa4", "#af17ff", "#260aff")
#' )
#'
#' # Creating a CrunchBox changing category-specific colors
#' crunchBox(ds[c("var1", "var2", "var3")],
#' title = "CrunchBox with category colors",
#' category_color_lookup = list(
#' "agree" = "#ff0aa4",
#' "disagree" = "#af17ff",
#' "don't know" = "#260aff"
#' )
#' )
#' }
#'
#' @seealso [`preCrunchBoxCheck()`] to provide guidance on what you're including in the
#' CrunchBox
#' @aliases crunchBox CrunchBox
#' @export
#' @importFrom grDevices col2rgb colors rgb
crunchBox <- function(dataset,
filters = crunch::filters(dataset),
weight = crunch::weight(dataset),
brand_colors,
static_colors,
category_color_lookup,
...) {
## Validate inputs
if (missing(dataset) || !is.dataset(dataset)) {
halt("'dataset' must be a CrunchDataset, potentially subsetted on variables")
}
if (is.null(filters)) {
## Make it an empty filter catalog so that it has methods we want below
filters <- FilterCatalog()
}
if (!inherits(filters, "FilterCatalog")) {
halt("'filters' should be a FilterCatalog or NULL")
}
if (!is.null(weight)) {
## TODO: could validate that weight is a weight variable
weight <- self(weight)
}
## Subset on non-hidden variables only
dataset <- dataset[names(dataset)]
## Check that we can compute everything without exploding the server
nvars <- length(variables(dataset))
nfilt <- length(filters)
if (boxTooBig(nvars, nfilt)) {
halt(
nvars, pluralize(" variable", nvars),
" and ", nfilt, pluralize(" filter", nfilt),
" results in too many cubes to fit in the box. ",
"Please try again with fewer of either."
)
}
## Construct the payload
payload <- list(
filters = lapply(urls(filters), function(x) list(filter = x)),
weight = weight,
...
)
## Add "where" after so that it no-ops if variablesFilter returns
## NULL (i.e. no filter)
payload$where <- variablesFilter(dataset)
## Add colors if they exist to the payload
if (!missing(brand_colors)) {
brand_colors <- check_brand_colors(brand_colors)
payload$display_settings$palette$brand_colors <- brand_colors
}
if (!missing(static_colors)) {
if (!vectorOrList(static_colors, "character")) {
halt(sQuote("static_colors"), " must be a vector or list of characters")
}
static_colors <- lapply(static_colors, validHexColor)
payload$display_settings$palette$static_colors <- static_colors
}
if (!missing(category_color_lookup)) {
if (!is.list(category_color_lookup) || is.null(names(category_color_lookup))) {
halt(sQuote("category_color_lookup"), " must be a named list")
}
category_color_lookup <- lapply(category_color_lookup, validHexColor)
payload$display_settings$palette$category_lookup <- category_color_lookup
}
## Send it
out <- crPOST(shojiURL(dataset, "catalogs", "boxdata"),
body = toJSON(do.call("wrapEntity", payload))
)
return(out)
}
check_brand_colors <- function(brand_colors) {
brand_labels <- c("primary", "secondary", "message")
if (!vectorOrList(brand_colors, "character")) {
halt(
sQuote("brand_colors"), " must be character vector or list",
" of characters"
)
}
if (length(brand_colors) > 3) {
halt(sQuote("brand_colors"), " must be at most 3 elements long")
}
# ensure is a list of valid colors
brand_colors <- lapply(brand_colors, validHexColor)
# if there are no names, name them according to position
# if there are names, check that they are the right ones.
if (is.null(names(brand_colors))) {
names(brand_colors) <- brand_labels[seq_along(brand_colors)]
} else if (any(!names(brand_colors) %in% brand_labels)) {
halt(
"If ", sQuote("brand_colors"), " is a named list, it must",
" contain only ",
serialPaste(dQuote(brand_labels), collapse = "and")
)
}
brand_colors
}
#' @rdname crunchBox
#' @export
CrunchBox <- crunchBox
## Make this a function so tests can mock it
.boxlimit <- function() 60000L
boxTooBig <- function(nvars, nfilters) {
## Make sure that the number of cubes the box will contain is below a threshold
nvars * (nvars - 1) * (nfilters + 1) > .boxlimit()
}
#' Check if a dataset will make a good CrunchBox
#'
#' CrunchBoxes allows you to share data with the world in a simple, easy to embed format.
#' However, not all datasets naturally translate to the CrunchBox format. This
#' function checks your dataset to see if it has variable & category definitions
#' that will work well with the CrunchBox format.
#'
#' @param dataset CrunchDataset, potentially subsetted on variables
#' @return Invisibly, the dataset. Called for side-effect of printing things.
#' @seealso [`CrunchBox`]
#' @export
preCrunchBoxCheck <- function(dataset) {
vm <- variableMetadata(dataset)[urls(variables(dataset))] ## [] for order of vars
keeps <- aliases(vm)
## 1. Variable types
suggested_types <- types(vm) %in% c("categorical", "multiple_response")
if (!all(suggested_types)) {
not_recommended_types <- !suggested_types
num_types <- sum(not_recommended_types)
cat(
"We recommend using only categorical and multiple_response",
"variables.", demonstrativeCount(num_types), "an unsupported type:\n"
)
print(data.frame(
alias = keeps[!suggested_types],
type = types(vm)[!suggested_types]
))
}
## 2. Shorter variable names will display in the menus better.
## Check threshold: 40 characters
name_length <- nchar(names(vm))
too_long_name <- name_length > 40
if (any(too_long_name)) {
num_too_long <- sum(too_long_name)
cat(
"Shorter variable names will display in the menus better.",
demonstrativeCount(num_too_long), "a name longer than 40 characters:\n"
)
print(data.frame(
alias = keeps[too_long_name],
length = name_length[too_long_name],
name = names(vm)[too_long_name]
))
}
## 3. Categories
## a. Too many categories won't plot well as bars. (Unless they define
## regions on a map.)
## Check threshold: 7 categories
## TODO: add checking for category color specifications?
num_cats <- vapply(vm, function(x) {
cats <- x$categories
if (is.null(cats)) {
return(0)
}
## We care only about non-missing categories
return(sum(vapply(cats, function(ctg) !isTRUE(ctg$missing), logical(1))))
}, numeric(1))
too_many_cats <- num_cats > 7
if (any(too_many_cats)) {
num_too_many <- sum(too_many_cats)
cat(
"Too many categories won't plot well.",
demonstrativeCount(num_too_many),
"more than 7 non-missing categories:\n"
)
print(data.frame(
alias = keeps[too_many_cats],
num_categories = num_cats[too_many_cats]
))
}
## b. Long category names won't fit well in the table headers, as bar/group
## labels, or in the graph legend.
## Check threshold: 40
longest_cat <- vapply(vm, function(x) {
cats <- x$categories
if (is.null(cats)) {
return("")
}
catnames <- vapply(cats, function(ctg) ctg$name, character(1))
return(catnames[which.max(nchar(catnames))])
}, character(1))
cat_length <- nchar(longest_cat)
too_long_cat <- cat_length > 40
if (any(too_long_cat)) {
num_too_long <- sum(too_long_cat)
cat(
"Shorter category names will fit in the tables and graphs better.",
demonstrativeCount(num_too_long),
"at least one category longer than 40 characters:\n"
)
print(data.frame(
alias = keeps[too_long_cat],
length = cat_length[too_long_cat],
category = longest_cat[too_long_cat]
))
}
## 4. Subvariables. Because multiple_response look like categorical when
## plotted, we'll use the same size/length check thresholds
num_subvars <- vapply(vm, function(x) length(x$subvariables), numeric(1))
too_many_subvars <- num_subvars > 7
if (any(too_many_subvars)) {
num_too_many <- sum(too_many_subvars)
cat(
"Too many subvariables won't plot well. ",
demonstrativeCount(num_too_many),
"more than 7 subvariables:\n"
)
print(data.frame(
alias = keeps[too_many_subvars],
num_subvariables = num_subvars[too_many_subvars]
))
}
longest_subvar <- vapply(vm, function(x) {
cats <- x$subreferences
if (is.null(cats)) {
return("")
}
catnames <- vapply(cats, function(ctg) ctg$name, character(1))
return(catnames[which.max(nchar(catnames))])
}, character(1))
subvar_length <- nchar(longest_subvar)
too_long_subvar <- subvar_length > 40
if (any(too_long_subvar)) {
num_too_long <- sum(too_long_subvar)
cat(
"Shorter subvariable names will fit in the tables and graphs better.",
demonstrativeCount(num_too_long),
"at least one subvariable longer than 40 characters:\n"
)
print(data.frame(
alias = keeps[too_long_subvar],
length = subvar_length[too_long_subvar],
subvariable = longest_subvar[too_long_subvar]
))
}
invisible(dataset)
}
demonstrativeCount <- function(n, noun = "variable") {
return(ifelse(n > 1, paste("These", n, "variables have"), "This variable has"))
}
#' Get HTML for embedding a CrunchBox
#'
#' [crunchBox()] returns a URL to the box data that it generates, but
#' in order to view it in a CrunchBox or to embed it on a website, you'll need
#' to translate that to the Box's public URL and wrap it in some HTML. This function
#' takes a CrunchBox and returns the HTML which you can embed in a website.
#'
#' @param box character URL of the box data, as returned by `crunchBox()`
#' @param title character title for the Box, to appear above the iframe. Default
#' is `NULL`, meaning no title shown
#' @param logo character URL of a logo to show instead of a title. Default is
#' `NULL`, meaning no logo shown. If both logo and title are provided, only the
#' logo will be shown. Note also that logo must be a URL of a hosted image: it
#' cannot be a path to a local file.
#' @param ... Additional arguments, not currently used.
#' @return Prints the HTML markup to the screen and also returns it invisibly.
#' @seealso [crunchBox()]
#' @examples
#' \dontrun{
#' box <- crunchBox(ds)
#' embedCrunchBox(box, logo = "//myco.example/img/logo_200px.png")
#' }
#' @export
embedCrunchBox <- function(box, title = NULL, logo = NULL, ...) {
iframe <- paste0(
'<iframe src="',
boxdataToWidgetURL(box),
'" width="600" height="480" style="border: 1px solid #d3d3d3;"></iframe>'
)
if (!is.null(logo)) {
iframe <- boxfig(
paste0(
'<img src="', logo,
'" style="height:auto; width:200px; margin-left:-4px"></img>'
),
iframe
)
} else if (!is.null(title)) {
iframe <- boxfig(
'<div style="padding-bottom: 12px">',
paste0(
' <span style="font-size: 18px; color: #444444; line-height: 1;">',
title, "</span>"
),
"</div>",
iframe
)
}
cat(iframe, "\n")
invisible(iframe)
}
boxdataToWidgetURL <- function(box) {
## Grab the box id hash from one URL and plug it into the public widget URL
sub(".*([0-9a-f]{32}).*", "//s.crunch.io/widget/index.html#/ds/\\1/", box)
}
boxfig <- function(...) {
## Wrap HTML in more HTML, a <figure> tag
paste0(
'<figure style="text-align: left;" class="content-list-component image">\n',
paste0(" ", c(...), "\n", collapse = ""),
"</figure>"
)
}
validHexColor <- function(color) {
## Given a color string, possibly an R color name, validate it and
## standardize its formatting like `#AABBCC`
if (!is.character(color)) {
halt("A color must be a character, got ", class(color), " instead")
}
# if color is an R color name like "aliceblue" convert to hex
if (color %in% colors()) {
color <- rgb(t(col2rgb(color) / 255))
} else {
if (!startsWith(color, "#")) {
color <- paste0("#", color)
}
if (!grepl("^#[[:xdigit:]]{6,8}$", color)) {
halt(dQuote(color), " is not a valid hex color.")
}
}
# remove the last two chars if given 8 digit version
return(substr(color, 1, 7))
}
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.