R/z_animint.R
In tdhock/animint2: Animated Interactive Grammar of Graphics
Defines functions
getLegendList
animint2dir
storeLayer
parsePlot
Documented in
animint2dir
getLegendList
parsePlot
#' Convert a ggplot to a list.
#' @param meta environment with previously calculated plot data, and a new plot to parse, already stored in plot and plot.name.
#' @param plot ggplot list object
#' @param plot.name name of plot
#' @return nothing, info is stored in meta.
#' @export
#' @import plyr
#' @importFrom methods is
parsePlot <- function(meta, plot, plot.name){
## adding data and mapping to each layer from base plot, if necessary
for(layer.i in seq_along(plot$layers)) {
## if data is not specified, get it from plot
if(length(plot$layers[[layer.i]]$data) == 0){
plot$layers[[layer.i]]$data <- plot$data
}
## if mapping is not specified, get it from plot
if(is.null(plot$layers[[layer.i]]$mapping)){
plot$layers[[layer.i]]$mapping <- plot$mapping
}
}
built <- ggplot_build(plot)
plot.info <- list()
## Export axis specification as a combination of breaks and
## labels, on the relevant axis scale (i.e. so that it can
## be passed into d3 on the x axis scale instead of on the
## grid 0-1 scale). This allows transformations to be used
## out of the box, with no additional d3 coding.
theme.pars <- plot_theme(plot)
## Interpret panel.margin as the number of lines between facets
## (ignoring whatever grid::unit such as cm that was specified).
## Now ggplot specifies panel.margin in 'pt' instead of 'lines'
plot.info$panel_margin_lines <- pt.to.lines(theme.pars$panel.margin)
## No legend if theme(legend.postion="none").
plot.info$legend <- if(theme.pars$legend.position != "none"){
getLegendList(built)
}
## scan for legends in each layer.
for(layer.i in seq_along(plot$layers)){
##cat(sprintf("%4d / %4d layers\n", layer.i, length(plot$layers)))
## This is the layer from the original ggplot object.
L <- plot$layers[[layer.i]]
## Use original mapping saved before calling parsePlot
## This is to handle cases where the plots may share the same layer
## If the layer mapping in one plot has been edited by the animint
## compiler, the layer mapping in the other plots will also change
## which will give error when we check if showSelected/clickSelects have
## been used as aesthetics
L$mapping <- L$orig_mapping
class(L$mapping) <- "list"
## If any legends are specified, add showSelected aesthetic
L <- addShowSelectedForLegend(meta, plot.info$legend, L)
## Check if showSelected and clickSelects have been used as aesthetics
## If yes, raise error
checkForSSandCSasAesthetics(L$mapping, plot.name)
## Handle the extra_params argument
## -> handles .value/.variable named params
## -> removes duplicates
## -> removes duplicates due to showSelected legend
L$extra_params <- checkExtraParams(L$extra_params, L$mapping)
## Add the showSelected/clickSelects params to the aesthetics
## mapping before calling ggplot_build
L$mapping <- addSSandCSasAesthetics(L$mapping, L$extra_params)
}#layer.i
## need to call ggplot_build again because we've added to the plot.
## I'm sure that there is a way around this, but not immediately sure how.
## There's sort of a Catch-22 here because to create the interactivity,
## we need to specify the variable corresponding to each legend.
## To do this, we need to have the legend.
## And to have the legend, I think that we need to use ggplot_build
built <- ggplot_build(plot)
## TODO: implement a compiler that does not call ggplot_build at
## all, and instead does all of the relevant computations in animint
## code.
## 'strips' are really titles for the different facet panels
plot.info$strips <- with(built, getStrips(plot$facet, panel))
## the layout tells us how to subset and where to plot on the JS side
plot.info$layout <- with(built, flag_axis(plot$facet, panel$layout))
plot.info$layout <- with(built, train_layout(
plot$facet, plot$coordinates, plot.info$layout, panel$ranges))
# saving background info
plot.info$panel_background <- get_bg(theme.pars$panel.background, theme.pars)
plot.info$panel_border <- get_bg(theme.pars$panel.border, theme.pars)
# extract major grid lines
plot.info$grid_major <- get_grid(theme.pars$panel.grid.major, theme.pars,
plot.info, meta, built)
# extract minor grid lines
plot.info$grid_minor <- get_grid(theme.pars$panel.grid.minor, theme.pars,
plot.info, meta, built, major = F)
## Flip labels if coords are flipped - transform does not take care
## of this. Do this BEFORE checking if it is blank or not, so that
## individual axes can be hidden appropriately, e.g. #1.
if("CoordFlip"%in%attr(plot$coordinates, "class")){
temp <- plot$labels$x
plot$labels$x <- plot$labels$y
plot$labels$y <- temp
}
is.blank <- function(el.name){
x <- calc_element(el.name, plot$theme)
"element_blank"%in%attr(x,"class")
}
# Instead of an "axis" JSON object for each plot,
# allow for "axis1", "axis2", etc. where
# "axis1" corresponds to the 1st PANEL
ranges <- built$panel$ranges
n.axis <- length(ranges)
axes <- setNames(vector("list", n.axis),
paste0("axis", seq_len(n.axis)))
plot.info <- c(plot.info, axes)
# translate axis information
for (xy in c("x", "y")) {
s <- function(tmp) sprintf(tmp, xy)
# one axis name per plot (ie, a xtitle/ytitle is shared across panels)
plot.info[[s("%stitle")]] <- if(is.blank(s("axis.title.%s"))){
""
} else {
scale.i <- which(plot$scales$find(xy))
lab.or.null <- if(length(scale.i) == 1){
plot$scales$scales[[scale.i]]$name
}
if(is.null(unlist(lab.or.null))){
plot$labels[[xy]]
}else{
lab.or.null
}
}
## panel text size.
plot.info[[s("strip_text_%ssize")]] <- getTextSize(
s("strip.text.%s"), theme.pars)
## axis text.
axis.text <- theme.pars[[s("axis.text.%s")]]
## axis text size.
plot.info[[s("%ssize")]] <- getTextSize(s("axis.text.%s"), theme.pars)
## axis text angle.
angle <- if(is.numeric(axis.text$angle)){
-axis.text$angle
}
if(is.null(angle)){
angle <- 0
}
plot.info[[s("%sangle")]] <- as.numeric(angle)
## axis text hjust->anchor.
anchor <- hjust2anchor(axis.text$hjust)
if(is.null(anchor)){
anchor <- if(angle == 0){
"middle"
}else{
"end"
}
}
plot.info[[s("%sanchor")]] <- as.character(anchor)
# translate panel specific axis info
ctr <- 0
for (axis in names(axes)) {
ctr <- ctr + 1
range <- ranges[[ctr]]
plot.info[[axis]][[xy]] <- as.list(range[[s("%s.major_source")]])
plot.info[[axis]][[s("%slab")]] <- if(is.blank(s("axis.text.%s"))){
NULL
} else {
as.list(range[[s("%s.labels")]])
}
plot.info[[axis]][[s("%srange")]] <- range[[s("%s.range")]]
plot.info[[axis]][[s("%sline")]] <- !is.blank(s("axis.line.%s"))
plot.info[[axis]][[s("%sticks")]] <- !is.blank(s("axis.ticks.%s"))
}
}
# grab the unique axis labels (makes rendering simpler)
plot.info <- getUniqueAxisLabels(plot.info)
# grab plot title if present
plot.info$title <- if(is(theme.pars$plot.title, "blank")){
""
}else{
plot$labels$title
}
plot.info$title_size <- getTextSize("plot.title", theme.pars)
## Set plot width and height from animint.* options if they are
## present.
options_list <- getWidthAndHeight(plot$theme)
options_list <- setUpdateAxes(plot$theme, options_list)
plot.info$options <- options_list
list(
plot.info=plot.info,
ggplot=plot,
built=built)
}
storeLayer <- function(meta, g, g.data.varied){
## Save each variable chunk to a separate tsv file.
meta$chunk.i <- 1L
meta$g <- g
g$chunks <- saveChunks(g.data.varied, meta)
g$total <- length(unlist(g$chunks))
## Finally save to the master geom list.
meta$geoms[[g$classed]] <- g
g
}
#' Compile and render an animint in a local directory.
#'
#' This function converts an animint plot.list into a directory of
#' files which can be used to render the interactive data
#' visualization in a web browser.
#' @param plot.list a named list of ggplots and option lists.
#' @param out.dir directory to store html/js/csv files. If it exists
#' already, it will be removed before writing the new
#' directory/files.
#' @param json.file character string that names the JSON file with
#' metadata associated with the plot.
#' @param open.browser logical (default TRUE if interactive), should R
#' open a browser? If TRUE, we look at the animint.browser option to
#' determine how. If it is set to "browseURL" then we use a file URL
#' (be sure to configure your browser to allow access to local
#' files, as some browsers block this by default). Otherwise
#' (default) we use \code{servr::httd(out.dir)}.
#' @param css.file character string for non-empty css file to
#' include. Provided file will be copied to the output directory as
#' styles.css
#' @return invisible list of ggplots in list format.
#' @export
#' @import RJSONIO
#' @importFrom utils browseURL head packageVersion str tail
#' write.table
#' @example inst/examples/animint2dir.R
animint2dir <- function(plot.list, out.dir = NULL,
json.file = "plot.json", open.browser = interactive(),
css.file = "") {
if(is.null(out.dir)){
out.dir <- tempfile()
}
animint.js <- file.path(out.dir, "animint.js")
if(dir.exists(out.dir) && !file.exists(animint.js)){
stop(animint.js, " does not exist, so not removing out.dir. If you really want to save your animint in out.dir, then please remove that directory entirely")
}
unlink(out.dir, recursive=TRUE)
## Check plot.list for errors
checkPlotList(plot.list)
## Store meta-data in this environment, so we can alter state in the
## lower-level functions.
meta <- newEnvironment()
meta$selector.types <- plot.list$selector.types
dir.create(out.dir,showWarnings=FALSE)
meta$out.dir <- out.dir
## First, copy html/js/json files to out.dir.
src.dir <- system.file("htmljs",package="animint2")
to.copy <- Sys.glob(file.path(src.dir, "*"))
if(file.exists(paste0(out.dir, "styles.css")) | css.file != "default.file"){
to.copy <- to.copy[!grepl("styles.css", to.copy, fixed=TRUE)]
}
if(css.file!=""){
# if css filename is provided, copy that file to the out directory as "styles.css"
to.copy <- to.copy[!grepl("styles.css", to.copy, fixed=TRUE)]
if(!file.exists(css.file)){
stop(paste("css.file", css.file, "does not exist. Please check that the file name and path are specified correctly."))
} else {
file.copy(css.file, file.path(out.dir, "styles.css"), overwrite=TRUE)
}
} else {
style.file <- system.file("htmljs", "styles.css", package = "animint2")
file.copy(style.file, file.path(out.dir, "styles.css"), overwrite=TRUE)
}
file.copy(to.copy, out.dir, overwrite=TRUE, recursive=TRUE)
## Store the animation information (time, var, ms) in a separate list
AnimationInfo <- list()
## Save the animation variable so we can treat it specially when we
## process each geom.
# CPS (7-22-14): What if the user doesn't specify milliseconds? Could we provide a reasonable default?
if(is.list(plot.list[["time"]])){
# Check animation variable for errors
checkAnimationTimeVar(plot.list$time)
AnimationInfo$time <- plot.list$time
ms <- AnimationInfo$time$ms
time.var <- AnimationInfo$time$variable
}
## The title option should just be a character, not a list.
if(is.list(plot.list$title)){
plot.list$title <- plot.list$title[[1]]
}
if(is.character(plot.list$title)){
meta$title <- plot.list$title[[1]]
plot.list$title <- NULL
}
if(!is.null(plot.list$out.dir)){
plot.list$out.dir <- NULL
}
if(is.character(plot.list[["source"]])){
meta$source <- plot.list[["source"]]
plot.list$source <- NULL
}
## Extract essential info from ggplots, reality checks.
for(list.name in names(plot.list)){
p <- plot.list[[list.name]]
if(is.ggplot(p)){
## Save original mapping to every layer so that we can use it afterwards
## This is required because we edit the original plot list created for the
## animint2dir function. See the discussion here:
## https://github.com/tdhock/animint2/pull/5#issuecomment-323072502
for(layer_i in seq_along(p$layers)){
## Viz has not been used before
if(is.null(p$layers[[layer_i]]$orig_mapping)){
p$layers[[layer_i]]$orig_mapping <-
if(is.null(p$layers[[layer_i]]$mapping)){
## Get mapping from plot if not defined in layer
p$mapping
}else{
p$layers[[layer_i]]$mapping
}
}else{
## This is not the first time this layer is being processed, so we replace
## the mapping with the original mapping here
p$layers[[layer_i]]$mapping <- p$layers[[layer_i]]$orig_mapping
}
}
## Before calling ggplot_build, we do some error checking for
## some animint extensions.
checkPlotForAnimintExtensions(p, list.name)
}else if(is.list(p)){ ## for options.
meta[[list.name]] <- p
}else{
stop("list items must be ggplots or option lists, problem: ", list.name)
}
}
## Call ggplot_build in parsPlot for all ggplots
ggplot.list <- list()
AllPlotsInfo <- list()
for(list.name in names(plot.list)){
p <- plot.list[[list.name]]
if(is.ggplot(p)){
## If plot is correct, save to meta for further processing
parsed_info <- parsePlot(meta, p, list.name) # calls ggplot_build.
AllPlotsInfo[[list.name]] <- parsed_info$plot.info
ggplot.list[[list.name]]$ggplot <- parsed_info$ggplot
ggplot.list[[list.name]]$built <- parsed_info$built
}
}
## After going through all of the meta-data in all of the ggplots,
## now we have enough info to save the TSV file database.
geom_num <- 0
g.list <- list()
for(p.name in names(ggplot.list)){
ggplot.info <- ggplot.list[[p.name]]
for(layer.i in seq_along(ggplot.info$ggplot$layers)){
L <- ggplot.info$ggplot$layers[[layer.i]]
df <- ggplot.info$built$data[[layer.i]]
## Data now contains columns with fill, alpha, colour etc.
## Remove from data if they have a single unique value and
## are NOT used in mapping to reduce tsv file size
redundant.cols <- names(L$geom$default_aes)
for(col.name in names(df)){
if(col.name %in% redundant.cols){
all.vals <- unique(df[[col.name]])
if(length(all.vals) == 1){
in.mapping <-
!is.null(L$mapping[[col.name]])
if(!in.mapping){
df[[col.name]] <- NULL
}
}
}
}
geom_num <- geom_num + 1
layer_name <- getLayerName(L, geom_num, p.name)
if(nrow(df)==0){
stop("no data in ", layer_name)
}
gl <- Geom$export_animint(
L, df, meta, layer_name,
ggplot.info$ggplot, ggplot.info$built, AnimationInfo)
## Save Animation Info separately
AnimationInfo$timeValues <- gl$timeValues
gl$timeValues <- NULL
## Save to a list before saving to tsv
## Helps during axis updates and Inf values
g.list[[p.name]][[gl$g$classed]] <- gl
}#layer.i
}
## Selector levels and update were stored in saveLayer, so now
## compute the unique values to store in meta$selectors.
for(selector.name in names(meta$selector.values)){
values.update <- meta$selector.values[[selector.name]]
value.vec <- unique(unlist(lapply(values.update, "[[", "values")))
meta$selectors[[selector.name]]$selected <- if(
meta$selectors[[selector.name]]$type=="single"){
value.vec[1]
}else{
value.vec
}
## Check the selectize option to determine if the designer wants
## to show a widget for this selector.
selectize <- meta$selectize[[selector.name]]
render.widget <- if(is.logical(selectize)){
selectize[1]
}else{
## If the designer did not set selectize, then we set a default
## (if .variable .value aes, then no selectize; otherwise if
## there are less than 1000 values then yes).
if(isTRUE(meta$selectors[[selector.name]]$is.variable.value)){
FALSE
}else{
if(length(value.vec) < 1000){
TRUE
}else{
FALSE
}
}
}
if(render.widget){
## Showing selectize widgets is optional, and indicated to the
## renderer by the compiler by not setting the "levels"
## attribute of the selector.
meta$selectors[[selector.name]]$levels <- value.vec
}
## s.info$update is the list of geom names that will be updated
## for this selector.
meta$selectors[[selector.name]]$update <-
as.list(unique(unlist(lapply(values.update, "[[", "update"))))
}
## For a static data viz with no interactive aes, no need to check
## for trivial showSelected variables with only 1 level.
checkSingleShowSelectedValue(meta$selectors)
## Go through options and add to the list.
for(v.name in names(meta$duration)){
meta$selectors[[v.name]]$duration <- meta$duration[[v.name]]
}
## Set plot sizes.
setPlotSizes(meta, AllPlotsInfo)
## Get domains of data subsets if theme_animint(update_axes) is used
for(p.name in names(ggplot.list)){
axes_to_update <- AllPlotsInfo[[p.name]]$options$update_axes
if(!is.null(axes_to_update)){
for (axis in axes_to_update){
subset_domains <- list()
# Determine if every panel needs a different domain or not
# We conclude here if we want to split the data by PANEL
# for the axes updates. Else every panel uses the same domain
panels <- ggplot.list[[p.name]]$built$panel$layout$PANEL
axes_drawn <-
ggplot.list[[p.name]]$built$panel$layout[[
paste0("AXIS_", toupper(axis))]]
panels_used <- panels[axes_drawn]
split_by_panel <- all(panels == panels_used)
for(layer.i in seq_along(ggplot.list[[p.name]]$built$plot$layers)){
## If there is a geom where the axes updates have non numeric values,
## we stop and throw an informative warning
## It does not make sense to have axes updates for non numeric values
aesthetic_names <- names(g.list[[p.name]][[layer.i]]$g$aes)
axis_pattern <- paste0("^", axis)
axis_col_name <- grep(axis_pattern, aesthetic_names, value=TRUE)
if(0==length(axis_col_name)){
##geom_abline does not have any x/y aes to contribute to
##the scale computations so we just ignore this layer --
##TODO all of this logic for computing the axes updates
##should be moved to the geom classes.
}else{
first_axis_name <- axis_col_name[[1]]
axis_col <- g.list[[p.name]][[layer.i]]$g$aes[[first_axis_name]]
axis_is_numeric <- is.numeric(
ggplot.list[[p.name]]$built$plot$layers[[
layer.i]]$data[[axis_col]])
if(!axis_is_numeric){
stop(paste0(
"'update_axes' specified for '", toupper(axis),
"' axis on plot '", p.name,
"' but the column '", axis_col, "' is non-numeric.",
" Axes updates are only available for numeric data."))
}
## handle cases for showSelected: showSelectedlegendfill,
## showSelectedlegendcolour etc.
choose_ss <- grepl("^showSelected", aesthetic_names)
ss_selectors <- g.list[[p.name]][[layer.i]]$g$aes[choose_ss]
## Do not calculate domains for multiple selectors
remove_ss <- c()
for(j in seq_along(ss_selectors)){
if(meta$selectors[[ ss_selectors[[j]] ]]$type != "single"){
remove_ss <- c(remove_ss, ss_selectors[j])
}
}
ss_selectors <- ss_selectors[!ss_selectors %in% remove_ss]
## Only save those selectors which are used by plot
for(ss in ss_selectors){
if(!ss %in% AllPlotsInfo[[p.name]]$axis_domains[[axis]]$selectors){
AllPlotsInfo[[p.name]]$axis_domains[[axis]]$selectors <- c(
ss, AllPlotsInfo[[p.name]]$axis_domains[[axis]]$selectors)
}
}
## Set up built_data to compute domains
built_data <-
ggplot.list[[p.name]]$built$plot$layers[[layer.i]]$data
built_data$PANEL <-
ggplot.list[[p.name]]$built$data[[layer.i]]$PANEL
if(length(ss_selectors) > 0){
subset_domains[layer.i] <- compute_domains(
built_data,
axis,
strsplit(names(g.list[[p.name]])[[layer.i]], "_")[[1]][[2]],
names(sort(ss_selectors)),
split_by_panel,
g.list[[p.name]][[layer.i]]$g$aes)
}
}
}##for(layer.i
subset_domains <- subset_domains[!sapply(subset_domains, is.null)]
if(length(subset_domains)==0){
warning(paste("update_axes specified for", toupper(axis),
"axis on plot", p.name,
"but found no geoms with showSelected=singleSelectionVariable,",
"so created a plot with no updates for",
toupper(axis), "axis"), call. = FALSE)
# Do not save in plot.json file if axes is not getting updated
update_axes <- AllPlotsInfo[[p.name]]$options$update_axes
AllPlotsInfo[[p.name]]$options$update_axes <-
update_axes[!axis == update_axes]
}else{
use_domain <- get_domain(subset_domains)
# Save for renderer
AllPlotsInfo[[p.name]]$axis_domains[[axis]]$domains <- use_domain
# Get gridlines for updates
AllPlotsInfo[[p.name]]$axis_domains[[axis]]$grids <-
get_ticks_gridlines(use_domain)
## Initially selected selector values are stored in curr_select
## which updates every time a user updates the axes
saved_selectors <- sort(names(meta$selectors))
for (ss in saved_selectors){
if(ss %in% AllPlotsInfo[[p.name]]$axis_domains[[axis]]$selectors){
AllPlotsInfo[[p.name]]$axis_domains[[axis]]$curr_select[[ss]] <-
meta$selectors[[ss]]$selected
}
}
}
}
}
}
## Finally save all the layers
for(p.name in names(ggplot.list)){
for(g1 in seq_along(g.list[[p.name]])){
g <- storeLayer(meta, g.list[[p.name]][[g1]]$g,
g.list[[p.name]][[g1]]$g.data.varied)
## Every plot has a list of geom names.
AllPlotsInfo[[p.name]]$geoms <- c(
AllPlotsInfo[[p.name]]$geoms, list(g$classed))
}
}
## Now that selectors are all defined, go back through geoms to
## check if there are any warnings to issue.
issueSelectorWarnings(meta$geoms, meta$selector.aes, meta$duration)
## These geoms need to be updated when the time.var is animated, so
## let's make a list of all possible values to cycle through, from
## all the values used in those geoms.
if("time" %in% names(AnimationInfo)){
meta$selectors[[AnimationInfo$time$variable]]$type <- "single"
anim.values <- AnimationInfo$timeValues
if(length(AnimationInfo$timeValues)==0){
stop("no interactive aes for time variable ", AnimationInfo$time$variable)
}
anim.not.null <- anim.values[!sapply(anim.values, is.null)]
time.classes <- sapply(anim.not.null, function(x) class(x)[1])
time.class <- time.classes[[1]]
if(any(time.class != time.classes)){
print(time.classes)
stop("time variables must all have the same class")
}
AnimationInfo$time$sequence <- if(time.class=="POSIXct"){
orderTime <- function(format){
values <- unlist(sapply(anim.not.null, strftime, format))
sort(unique(as.character(values)))
}
hms <- orderTime("%H:%M:%S")
f <- if(length(hms) == 1){
"%Y-%m-%d"
}else{
"%Y-%m-%d %H:%M:%S"
}
orderTime(f)
}else if(time.class=="factor"){
levs <- levels(anim.not.null[[1]])
if(any(sapply(anim.not.null, function(f)levels(f)!=levs))){
print(sapply(anim.not.null, levels))
stop("all time factors must have same levels")
}
levs
}else{ #character, numeric, integer, ... what else?
as.character(sort(unique(unlist(anim.not.null))))
}
meta$selectors[[time.var]]$selected <- AnimationInfo$time$sequence[[1]]
}
## The first selection:
for(selector.name in names(meta$first)){
first <- as.character(meta$first[[selector.name]])
if(selector.name %in% names(meta$selectors)){
s.type <- meta$selectors[[selector.name]]$type
if(s.type == "single"){
stopifnot(length(first) == 1)
}
meta$selectors[[selector.name]]$selected <- first
}else{
print(list(selectors=names(meta$selectors),
missing.first=selector.name))
stop("missing first selector variable")
}
}
meta$plots <- AllPlotsInfo
meta$time <- AnimationInfo$time
meta$timeValues <- AnimationInfo$timeValues
export.names <- c(
"geoms", "time", "duration", "selectors", "plots", "title", "source")
export.data <- list()
for(export.name in export.names){
if(export.name %in% ls(meta)){
export.data[[export.name]] <- meta[[export.name]]
}
}
json <- RJSONIO::toJSON(export.data)
cat(json, file = file.path(out.dir, json.file))
if (open.browser) {
if (identical(getOption("animint.browser"),"browseURL")) {
u <- normalizePath(file.path(out.dir, "index.html"))
browseURL(u)
} else {
servr::httd(normalizePath(out.dir,winslash="/"))
}
}
## After everything has been done, we restore the original mappings
## in the plot.list. This is necessary for visualizations where we use
## the same plot.list with minor edits in another viz
## See this comment:
## https://github.com/tdhock/animint2/pull/5#issuecomment-323074518
for(plot_i in ggplot.list){
for(layer_i in seq_along(plot_i$ggplot$layers)){
plot_i$ggplot$layers[[layer_i]]$mapping <-
plot_i$ggplot$layers[[layer_i]]$orig_mapping
}
}
invisible(meta)
### An invisible copy of the R list that was exported to JSON.
}
#' Function to get legend information from ggplot
#' @param plistextra output from ggplot_build(p)
#' @return list containing information for each legend
#' @export
getLegendList <- function(plistextra){
plot <- plistextra$plot
scales <- plot$scales
layers <- plot$layers
default_mapping <- plot$mapping
theme <- plot_theme(plot)
position <- theme$legend.position
text <- theme$legend.text
title <- theme$legend.title
# by default, guide boxes are vertically aligned
if(is.null(theme$legend.box)) theme$legend.box <- "vertical" else theme$legend.box
# size of key (also used for bar in colorbar guide)
if(is.null(theme$legend.key.width)) theme$legend.key.width <- theme$legend.key.size
if(is.null(theme$legend.key.height)) theme$legend.key.height <- theme$legend.key.size
# by default, direction of each guide depends on the position of the guide.
if(is.null(theme$legend.direction)){
theme$legend.direction <-
if (length(position) == 1 && position %in% c("top", "bottom", "left", "right"))
switch(position[1], top =, bottom = "horizontal", left =, right = "vertical")
else
"vertical"
}
# justification of legend boxes
theme$legend.box.just <-
if(is.null(theme$legend.box.just)) {
if (length(position) == 1 && position %in% c("top", "bottom", "left", "right"))
switch(position, bottom =, top = c("center", "top"), left =, right = c("left", "top"))
else
c("center", "center")
}
position <- theme$legend.position
# locate guide argument in scale_*, and use that for a default.
# Note, however, that guides(colour = ...) has precendence! See https://gist.github.com/cpsievert/ece28830a6c992b29ab6
guides.args <- list()
for(aes.name in c("colour", "fill")){
aes.loc <- which(scales$find(aes.name))
guide.type <- if (length(aes.loc) == 1){
scales$scales[[aes.loc]][["guide"]]
}else{
"legend"
}
if(guide.type=="colourbar")guide.type <- "legend"
guides.args[[aes.name]] <- guide.type
}
guides.result <- do.call(guides, guides.args)
guides.list <- plyr::defaults(plot$guides, guides.result)
gdefs <- guides_train(scales = scales,
theme = theme,
guides = guides.list,
labels = plot$labels)
if (length(gdefs) != 0) {
gdefs <- guides_merge(gdefs)
gdefs <- guides_geom(gdefs, layers, default_mapping)
} else (zeroGrob())
names(gdefs) <- sapply(gdefs, function(i) i$title)
## adding the variable used to each LegendList
for(leg in seq_along(gdefs)) {
legend_type <- names(gdefs[[leg]]$key)
legend_type <- legend_type[legend_type != ".label"]
gdefs[[leg]]$legend_type <- legend_type
scale.list <- scales$scales[which(scales$find(legend_type))]
discrete.vec <- sapply(scale.list, inherits, "ScaleDiscrete")
is.discrete <- all(discrete.vec)
gdefs[[leg]]$is.discrete <- is.discrete
gdefs[[leg]]$text_size <- getTextSize("legend.text", theme)
gdefs[[leg]]$title_size <- getTextSize("legend.title", theme)
## get the name of the legend/selection variable.
var.list <- list()
for(layer.i in seq_along(plot$layers)) {
L <- plot$layers[[layer.i]]
var.list[[layer.i]] <- L$mapping[legend_type]
}
unique.var.list <- unique(unlist(var.list))
if(is.discrete){
var.name <- unique.var.list[[1]]
if(length(unique.var.list) == 1 && is.symbol(var.name)){
gdefs[[leg]]$selector <- paste(var.name)
}else{
str(unique.var.list)
stop("need exactly 1 variable name ",
"(not constant, not language/expression) ",
"to create interactive discrete legend for aes ",
paste(legend_type, collapse=", "))
}
}
## do not draw geoms which are constant:
geom.list <- gdefs[[leg]]$geoms
geom.data.list <- lapply(geom.list, "[[", "data")
geom.data.rows <- sapply(geom.data.list, nrow)
geom.unique.list <- lapply(geom.data.list, unique)
geom.unique.rows <- sapply(geom.unique.list, nrow)
is.ignored <- 1 < geom.data.rows & geom.unique.rows == 1
gdefs[[leg]]$geoms <- geom.list[!is.ignored]
## Pass a geom.legend.list to be used by the
## GetLegend function
geom.legend.list <- list()
for(geom.i in seq_along(gdefs[[leg]]$geoms)){
data.geom.i <- gdefs[[leg]]$geoms[[geom.i]]$data
params.geom.i <- gdefs[[leg]]$geoms[[geom.i]]$params
size.geom.i <- gdefs[[leg]]$geoms[[geom.i]]$size
suppressWarnings(draw.key.used <-
gdefs[[leg]]$geoms[[geom.i]]$draw_key(
data.geom.i, params.geom.i, size.geom.i)
)
geom.legend <- class(draw.key.used)[[1]]
geom.legend.list <- c(geom.legend.list, geom.legend)
}
## Process names to be used by the CleanData function
convert.names.list <- list(points="point", segments="path", rect="polygon")
names.to.change <- geom.legend.list %in% names(convert.names.list)
geom.legend.list[names.to.change] <-
convert.names.list[unlist(geom.legend.list[names.to.change])]
gdefs[[leg]]$geom.legend.list <- geom.legend.list
}
## Add a flag to specify whether or not breaks was manually
## specified. If it was, then it should be respected. If not, and
## the legend shows a numeric variable, then it should be reversed.
for(legend.name in names(gdefs)){
key.df <- gdefs[[legend.name]]$key
aes.name <- names(key.df)[1]
scale.i <- which(scales$find(aes.name))
if(length(scale.i) == 1){
sc <- scales$scales[[scale.i]]
gdefs[[legend.name]]$breaks <- sc$breaks
}
}
legend.list <- lapply(gdefs, getLegend)
## Add a flag to specify whether or not there is both a color and a
## fill legend to display. If so, we need to draw the interior of
## the points in the color legend as the same color.
if(1 < length(legend.list)){
is.color <- sapply(legend.list, function(L)"colour" %in% L$legend_type)
is.fill <- sapply(legend.list, function(L)"fill" %in% L$legend_type)
is.point <- sapply(legend.list, function(L)"point" %in% L$geoms)
has.both <- 2 == sum(is.point & (is.color | is.fill))
if(has.both){
for(legend.i in which(is.color)){
entry.list <- legend.list[[legend.i]]$entries
for(entry.i in seq_along(entry.list)){
entry <- entry.list[[entry.i]]
color.names <- grep("colour", names(entry), value=TRUE)
fill.names <- sub("colour", "fill", color.names)
entry[fill.names] <- "#FFFFFF"
legend.list[[legend.i]]$entries[[entry.i]] <- entry
}
}
}
}
legend.list[0 < sapply(legend.list, length)]
}
tdhock/animint2 documentation built on April 14, 2024, 4:22 p.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 getLegendList animint2dir storeLayer parsePlot
Documented in animint2dir getLegendList parsePlot
#' Convert a ggplot to a list.
#' @param meta environment with previously calculated plot data, and a new plot to parse, already stored in plot and plot.name.
#' @param plot ggplot list object
#' @param plot.name name of plot
#' @return nothing, info is stored in meta.
#' @export
#' @import plyr
#' @importFrom methods is
parsePlot <- function(meta, plot, plot.name){
## adding data and mapping to each layer from base plot, if necessary
for(layer.i in seq_along(plot$layers)) {
## if data is not specified, get it from plot
if(length(plot$layers[[layer.i]]$data) == 0){
plot$layers[[layer.i]]$data <- plot$data
}
## if mapping is not specified, get it from plot
if(is.null(plot$layers[[layer.i]]$mapping)){
plot$layers[[layer.i]]$mapping <- plot$mapping
}
}
built <- ggplot_build(plot)
plot.info <- list()
## Export axis specification as a combination of breaks and
## labels, on the relevant axis scale (i.e. so that it can
## be passed into d3 on the x axis scale instead of on the
## grid 0-1 scale). This allows transformations to be used
## out of the box, with no additional d3 coding.
theme.pars <- plot_theme(plot)
## Interpret panel.margin as the number of lines between facets
## (ignoring whatever grid::unit such as cm that was specified).
## Now ggplot specifies panel.margin in 'pt' instead of 'lines'
plot.info$panel_margin_lines <- pt.to.lines(theme.pars$panel.margin)
## No legend if theme(legend.postion="none").
plot.info$legend <- if(theme.pars$legend.position != "none"){
getLegendList(built)
}
## scan for legends in each layer.
for(layer.i in seq_along(plot$layers)){
##cat(sprintf("%4d / %4d layers\n", layer.i, length(plot$layers)))
## This is the layer from the original ggplot object.
L <- plot$layers[[layer.i]]
## Use original mapping saved before calling parsePlot
## This is to handle cases where the plots may share the same layer
## If the layer mapping in one plot has been edited by the animint
## compiler, the layer mapping in the other plots will also change
## which will give error when we check if showSelected/clickSelects have
## been used as aesthetics
L$mapping <- L$orig_mapping
class(L$mapping) <- "list"
## If any legends are specified, add showSelected aesthetic
L <- addShowSelectedForLegend(meta, plot.info$legend, L)
## Check if showSelected and clickSelects have been used as aesthetics
## If yes, raise error
checkForSSandCSasAesthetics(L$mapping, plot.name)
## Handle the extra_params argument
## -> handles .value/.variable named params
## -> removes duplicates
## -> removes duplicates due to showSelected legend
L$extra_params <- checkExtraParams(L$extra_params, L$mapping)
## Add the showSelected/clickSelects params to the aesthetics
## mapping before calling ggplot_build
L$mapping <- addSSandCSasAesthetics(L$mapping, L$extra_params)
}#layer.i
## need to call ggplot_build again because we've added to the plot.
## I'm sure that there is a way around this, but not immediately sure how.
## There's sort of a Catch-22 here because to create the interactivity,
## we need to specify the variable corresponding to each legend.
## To do this, we need to have the legend.
## And to have the legend, I think that we need to use ggplot_build
built <- ggplot_build(plot)
## TODO: implement a compiler that does not call ggplot_build at
## all, and instead does all of the relevant computations in animint
## code.
## 'strips' are really titles for the different facet panels
plot.info$strips <- with(built, getStrips(plot$facet, panel))
## the layout tells us how to subset and where to plot on the JS side
plot.info$layout <- with(built, flag_axis(plot$facet, panel$layout))
plot.info$layout <- with(built, train_layout(
plot$facet, plot$coordinates, plot.info$layout, panel$ranges))
# saving background info
plot.info$panel_background <- get_bg(theme.pars$panel.background, theme.pars)
plot.info$panel_border <- get_bg(theme.pars$panel.border, theme.pars)
# extract major grid lines
plot.info$grid_major <- get_grid(theme.pars$panel.grid.major, theme.pars,
plot.info, meta, built)
# extract minor grid lines
plot.info$grid_minor <- get_grid(theme.pars$panel.grid.minor, theme.pars,
plot.info, meta, built, major = F)
## Flip labels if coords are flipped - transform does not take care
## of this. Do this BEFORE checking if it is blank or not, so that
## individual axes can be hidden appropriately, e.g. #1.
if("CoordFlip"%in%attr(plot$coordinates, "class")){
temp <- plot$labels$x
plot$labels$x <- plot$labels$y
plot$labels$y <- temp
}
is.blank <- function(el.name){
x <- calc_element(el.name, plot$theme)
"element_blank"%in%attr(x,"class")
}
# Instead of an "axis" JSON object for each plot,
# allow for "axis1", "axis2", etc. where
# "axis1" corresponds to the 1st PANEL
ranges <- built$panel$ranges
n.axis <- length(ranges)
axes <- setNames(vector("list", n.axis),
paste0("axis", seq_len(n.axis)))
plot.info <- c(plot.info, axes)
# translate axis information
for (xy in c("x", "y")) {
s <- function(tmp) sprintf(tmp, xy)
# one axis name per plot (ie, a xtitle/ytitle is shared across panels)
plot.info[[s("%stitle")]] <- if(is.blank(s("axis.title.%s"))){
""
} else {
scale.i <- which(plot$scales$find(xy))
lab.or.null <- if(length(scale.i) == 1){
plot$scales$scales[[scale.i]]$name
}
if(is.null(unlist(lab.or.null))){
plot$labels[[xy]]
}else{
lab.or.null
}
}
## panel text size.
plot.info[[s("strip_text_%ssize")]] <- getTextSize(
s("strip.text.%s"), theme.pars)
## axis text.
axis.text <- theme.pars[[s("axis.text.%s")]]
## axis text size.
plot.info[[s("%ssize")]] <- getTextSize(s("axis.text.%s"), theme.pars)
## axis text angle.
angle <- if(is.numeric(axis.text$angle)){
-axis.text$angle
}
if(is.null(angle)){
angle <- 0
}
plot.info[[s("%sangle")]] <- as.numeric(angle)
## axis text hjust->anchor.
anchor <- hjust2anchor(axis.text$hjust)
if(is.null(anchor)){
anchor <- if(angle == 0){
"middle"
}else{
"end"
}
}
plot.info[[s("%sanchor")]] <- as.character(anchor)
# translate panel specific axis info
ctr <- 0
for (axis in names(axes)) {
ctr <- ctr + 1
range <- ranges[[ctr]]
plot.info[[axis]][[xy]] <- as.list(range[[s("%s.major_source")]])
plot.info[[axis]][[s("%slab")]] <- if(is.blank(s("axis.text.%s"))){
NULL
} else {
as.list(range[[s("%s.labels")]])
}
plot.info[[axis]][[s("%srange")]] <- range[[s("%s.range")]]
plot.info[[axis]][[s("%sline")]] <- !is.blank(s("axis.line.%s"))
plot.info[[axis]][[s("%sticks")]] <- !is.blank(s("axis.ticks.%s"))
}
}
# grab the unique axis labels (makes rendering simpler)
plot.info <- getUniqueAxisLabels(plot.info)
# grab plot title if present
plot.info$title <- if(is(theme.pars$plot.title, "blank")){
""
}else{
plot$labels$title
}
plot.info$title_size <- getTextSize("plot.title", theme.pars)
## Set plot width and height from animint.* options if they are
## present.
options_list <- getWidthAndHeight(plot$theme)
options_list <- setUpdateAxes(plot$theme, options_list)
plot.info$options <- options_list
list(
plot.info=plot.info,
ggplot=plot,
built=built)
}
storeLayer <- function(meta, g, g.data.varied){
## Save each variable chunk to a separate tsv file.
meta$chunk.i <- 1L
meta$g <- g
g$chunks <- saveChunks(g.data.varied, meta)
g$total <- length(unlist(g$chunks))
## Finally save to the master geom list.
meta$geoms[[g$classed]] <- g
g
}
#' Compile and render an animint in a local directory.
#'
#' This function converts an animint plot.list into a directory of
#' files which can be used to render the interactive data
#' visualization in a web browser.
#' @param plot.list a named list of ggplots and option lists.
#' @param out.dir directory to store html/js/csv files. If it exists
#' already, it will be removed before writing the new
#' directory/files.
#' @param json.file character string that names the JSON file with
#' metadata associated with the plot.
#' @param open.browser logical (default TRUE if interactive), should R
#' open a browser? If TRUE, we look at the animint.browser option to
#' determine how. If it is set to "browseURL" then we use a file URL
#' (be sure to configure your browser to allow access to local
#' files, as some browsers block this by default). Otherwise
#' (default) we use \code{servr::httd(out.dir)}.
#' @param css.file character string for non-empty css file to
#' include. Provided file will be copied to the output directory as
#' styles.css
#' @return invisible list of ggplots in list format.
#' @export
#' @import RJSONIO
#' @importFrom utils browseURL head packageVersion str tail
#' write.table
#' @example inst/examples/animint2dir.R
animint2dir <- function(plot.list, out.dir = NULL,
json.file = "plot.json", open.browser = interactive(),
css.file = "") {
if(is.null(out.dir)){
out.dir <- tempfile()
}
animint.js <- file.path(out.dir, "animint.js")
if(dir.exists(out.dir) && !file.exists(animint.js)){
stop(animint.js, " does not exist, so not removing out.dir. If you really want to save your animint in out.dir, then please remove that directory entirely")
}
unlink(out.dir, recursive=TRUE)
## Check plot.list for errors
checkPlotList(plot.list)
## Store meta-data in this environment, so we can alter state in the
## lower-level functions.
meta <- newEnvironment()
meta$selector.types <- plot.list$selector.types
dir.create(out.dir,showWarnings=FALSE)
meta$out.dir <- out.dir
## First, copy html/js/json files to out.dir.
src.dir <- system.file("htmljs",package="animint2")
to.copy <- Sys.glob(file.path(src.dir, "*"))
if(file.exists(paste0(out.dir, "styles.css")) | css.file != "default.file"){
to.copy <- to.copy[!grepl("styles.css", to.copy, fixed=TRUE)]
}
if(css.file!=""){
# if css filename is provided, copy that file to the out directory as "styles.css"
to.copy <- to.copy[!grepl("styles.css", to.copy, fixed=TRUE)]
if(!file.exists(css.file)){
stop(paste("css.file", css.file, "does not exist. Please check that the file name and path are specified correctly."))
} else {
file.copy(css.file, file.path(out.dir, "styles.css"), overwrite=TRUE)
}
} else {
style.file <- system.file("htmljs", "styles.css", package = "animint2")
file.copy(style.file, file.path(out.dir, "styles.css"), overwrite=TRUE)
}
file.copy(to.copy, out.dir, overwrite=TRUE, recursive=TRUE)
## Store the animation information (time, var, ms) in a separate list
AnimationInfo <- list()
## Save the animation variable so we can treat it specially when we
## process each geom.
# CPS (7-22-14): What if the user doesn't specify milliseconds? Could we provide a reasonable default?
if(is.list(plot.list[["time"]])){
# Check animation variable for errors
checkAnimationTimeVar(plot.list$time)
AnimationInfo$time <- plot.list$time
ms <- AnimationInfo$time$ms
time.var <- AnimationInfo$time$variable
}
## The title option should just be a character, not a list.
if(is.list(plot.list$title)){
plot.list$title <- plot.list$title[[1]]
}
if(is.character(plot.list$title)){
meta$title <- plot.list$title[[1]]
plot.list$title <- NULL
}
if(!is.null(plot.list$out.dir)){
plot.list$out.dir <- NULL
}
if(is.character(plot.list[["source"]])){
meta$source <- plot.list[["source"]]
plot.list$source <- NULL
}
## Extract essential info from ggplots, reality checks.
for(list.name in names(plot.list)){
p <- plot.list[[list.name]]
if(is.ggplot(p)){
## Save original mapping to every layer so that we can use it afterwards
## This is required because we edit the original plot list created for the
## animint2dir function. See the discussion here:
## https://github.com/tdhock/animint2/pull/5#issuecomment-323072502
for(layer_i in seq_along(p$layers)){
## Viz has not been used before
if(is.null(p$layers[[layer_i]]$orig_mapping)){
p$layers[[layer_i]]$orig_mapping <-
if(is.null(p$layers[[layer_i]]$mapping)){
## Get mapping from plot if not defined in layer
p$mapping
}else{
p$layers[[layer_i]]$mapping
}
}else{
## This is not the first time this layer is being processed, so we replace
## the mapping with the original mapping here
p$layers[[layer_i]]$mapping <- p$layers[[layer_i]]$orig_mapping
}
}
## Before calling ggplot_build, we do some error checking for
## some animint extensions.
checkPlotForAnimintExtensions(p, list.name)
}else if(is.list(p)){ ## for options.
meta[[list.name]] <- p
}else{
stop("list items must be ggplots or option lists, problem: ", list.name)
}
}
## Call ggplot_build in parsPlot for all ggplots
ggplot.list <- list()
AllPlotsInfo <- list()
for(list.name in names(plot.list)){
p <- plot.list[[list.name]]
if(is.ggplot(p)){
## If plot is correct, save to meta for further processing
parsed_info <- parsePlot(meta, p, list.name) # calls ggplot_build.
AllPlotsInfo[[list.name]] <- parsed_info$plot.info
ggplot.list[[list.name]]$ggplot <- parsed_info$ggplot
ggplot.list[[list.name]]$built <- parsed_info$built
}
}
## After going through all of the meta-data in all of the ggplots,
## now we have enough info to save the TSV file database.
geom_num <- 0
g.list <- list()
for(p.name in names(ggplot.list)){
ggplot.info <- ggplot.list[[p.name]]
for(layer.i in seq_along(ggplot.info$ggplot$layers)){
L <- ggplot.info$ggplot$layers[[layer.i]]
df <- ggplot.info$built$data[[layer.i]]
## Data now contains columns with fill, alpha, colour etc.
## Remove from data if they have a single unique value and
## are NOT used in mapping to reduce tsv file size
redundant.cols <- names(L$geom$default_aes)
for(col.name in names(df)){
if(col.name %in% redundant.cols){
all.vals <- unique(df[[col.name]])
if(length(all.vals) == 1){
in.mapping <-
!is.null(L$mapping[[col.name]])
if(!in.mapping){
df[[col.name]] <- NULL
}
}
}
}
geom_num <- geom_num + 1
layer_name <- getLayerName(L, geom_num, p.name)
if(nrow(df)==0){
stop("no data in ", layer_name)
}
gl <- Geom$export_animint(
L, df, meta, layer_name,
ggplot.info$ggplot, ggplot.info$built, AnimationInfo)
## Save Animation Info separately
AnimationInfo$timeValues <- gl$timeValues
gl$timeValues <- NULL
## Save to a list before saving to tsv
## Helps during axis updates and Inf values
g.list[[p.name]][[gl$g$classed]] <- gl
}#layer.i
}
## Selector levels and update were stored in saveLayer, so now
## compute the unique values to store in meta$selectors.
for(selector.name in names(meta$selector.values)){
values.update <- meta$selector.values[[selector.name]]
value.vec <- unique(unlist(lapply(values.update, "[[", "values")))
meta$selectors[[selector.name]]$selected <- if(
meta$selectors[[selector.name]]$type=="single"){
value.vec[1]
}else{
value.vec
}
## Check the selectize option to determine if the designer wants
## to show a widget for this selector.
selectize <- meta$selectize[[selector.name]]
render.widget <- if(is.logical(selectize)){
selectize[1]
}else{
## If the designer did not set selectize, then we set a default
## (if .variable .value aes, then no selectize; otherwise if
## there are less than 1000 values then yes).
if(isTRUE(meta$selectors[[selector.name]]$is.variable.value)){
FALSE
}else{
if(length(value.vec) < 1000){
TRUE
}else{
FALSE
}
}
}
if(render.widget){
## Showing selectize widgets is optional, and indicated to the
## renderer by the compiler by not setting the "levels"
## attribute of the selector.
meta$selectors[[selector.name]]$levels <- value.vec
}
## s.info$update is the list of geom names that will be updated
## for this selector.
meta$selectors[[selector.name]]$update <-
as.list(unique(unlist(lapply(values.update, "[[", "update"))))
}
## For a static data viz with no interactive aes, no need to check
## for trivial showSelected variables with only 1 level.
checkSingleShowSelectedValue(meta$selectors)
## Go through options and add to the list.
for(v.name in names(meta$duration)){
meta$selectors[[v.name]]$duration <- meta$duration[[v.name]]
}
## Set plot sizes.
setPlotSizes(meta, AllPlotsInfo)
## Get domains of data subsets if theme_animint(update_axes) is used
for(p.name in names(ggplot.list)){
axes_to_update <- AllPlotsInfo[[p.name]]$options$update_axes
if(!is.null(axes_to_update)){
for (axis in axes_to_update){
subset_domains <- list()
# Determine if every panel needs a different domain or not
# We conclude here if we want to split the data by PANEL
# for the axes updates. Else every panel uses the same domain
panels <- ggplot.list[[p.name]]$built$panel$layout$PANEL
axes_drawn <-
ggplot.list[[p.name]]$built$panel$layout[[
paste0("AXIS_", toupper(axis))]]
panels_used <- panels[axes_drawn]
split_by_panel <- all(panels == panels_used)
for(layer.i in seq_along(ggplot.list[[p.name]]$built$plot$layers)){
## If there is a geom where the axes updates have non numeric values,
## we stop and throw an informative warning
## It does not make sense to have axes updates for non numeric values
aesthetic_names <- names(g.list[[p.name]][[layer.i]]$g$aes)
axis_pattern <- paste0("^", axis)
axis_col_name <- grep(axis_pattern, aesthetic_names, value=TRUE)
if(0==length(axis_col_name)){
##geom_abline does not have any x/y aes to contribute to
##the scale computations so we just ignore this layer --
##TODO all of this logic for computing the axes updates
##should be moved to the geom classes.
}else{
first_axis_name <- axis_col_name[[1]]
axis_col <- g.list[[p.name]][[layer.i]]$g$aes[[first_axis_name]]
axis_is_numeric <- is.numeric(
ggplot.list[[p.name]]$built$plot$layers[[
layer.i]]$data[[axis_col]])
if(!axis_is_numeric){
stop(paste0(
"'update_axes' specified for '", toupper(axis),
"' axis on plot '", p.name,
"' but the column '", axis_col, "' is non-numeric.",
" Axes updates are only available for numeric data."))
}
## handle cases for showSelected: showSelectedlegendfill,
## showSelectedlegendcolour etc.
choose_ss <- grepl("^showSelected", aesthetic_names)
ss_selectors <- g.list[[p.name]][[layer.i]]$g$aes[choose_ss]
## Do not calculate domains for multiple selectors
remove_ss <- c()
for(j in seq_along(ss_selectors)){
if(meta$selectors[[ ss_selectors[[j]] ]]$type != "single"){
remove_ss <- c(remove_ss, ss_selectors[j])
}
}
ss_selectors <- ss_selectors[!ss_selectors %in% remove_ss]
## Only save those selectors which are used by plot
for(ss in ss_selectors){
if(!ss %in% AllPlotsInfo[[p.name]]$axis_domains[[axis]]$selectors){
AllPlotsInfo[[p.name]]$axis_domains[[axis]]$selectors <- c(
ss, AllPlotsInfo[[p.name]]$axis_domains[[axis]]$selectors)
}
}
## Set up built_data to compute domains
built_data <-
ggplot.list[[p.name]]$built$plot$layers[[layer.i]]$data
built_data$PANEL <-
ggplot.list[[p.name]]$built$data[[layer.i]]$PANEL
if(length(ss_selectors) > 0){
subset_domains[layer.i] <- compute_domains(
built_data,
axis,
strsplit(names(g.list[[p.name]])[[layer.i]], "_")[[1]][[2]],
names(sort(ss_selectors)),
split_by_panel,
g.list[[p.name]][[layer.i]]$g$aes)
}
}
}##for(layer.i
subset_domains <- subset_domains[!sapply(subset_domains, is.null)]
if(length(subset_domains)==0){
warning(paste("update_axes specified for", toupper(axis),
"axis on plot", p.name,
"but found no geoms with showSelected=singleSelectionVariable,",
"so created a plot with no updates for",
toupper(axis), "axis"), call. = FALSE)
# Do not save in plot.json file if axes is not getting updated
update_axes <- AllPlotsInfo[[p.name]]$options$update_axes
AllPlotsInfo[[p.name]]$options$update_axes <-
update_axes[!axis == update_axes]
}else{
use_domain <- get_domain(subset_domains)
# Save for renderer
AllPlotsInfo[[p.name]]$axis_domains[[axis]]$domains <- use_domain
# Get gridlines for updates
AllPlotsInfo[[p.name]]$axis_domains[[axis]]$grids <-
get_ticks_gridlines(use_domain)
## Initially selected selector values are stored in curr_select
## which updates every time a user updates the axes
saved_selectors <- sort(names(meta$selectors))
for (ss in saved_selectors){
if(ss %in% AllPlotsInfo[[p.name]]$axis_domains[[axis]]$selectors){
AllPlotsInfo[[p.name]]$axis_domains[[axis]]$curr_select[[ss]] <-
meta$selectors[[ss]]$selected
}
}
}
}
}
}
## Finally save all the layers
for(p.name in names(ggplot.list)){
for(g1 in seq_along(g.list[[p.name]])){
g <- storeLayer(meta, g.list[[p.name]][[g1]]$g,
g.list[[p.name]][[g1]]$g.data.varied)
## Every plot has a list of geom names.
AllPlotsInfo[[p.name]]$geoms <- c(
AllPlotsInfo[[p.name]]$geoms, list(g$classed))
}
}
## Now that selectors are all defined, go back through geoms to
## check if there are any warnings to issue.
issueSelectorWarnings(meta$geoms, meta$selector.aes, meta$duration)
## These geoms need to be updated when the time.var is animated, so
## let's make a list of all possible values to cycle through, from
## all the values used in those geoms.
if("time" %in% names(AnimationInfo)){
meta$selectors[[AnimationInfo$time$variable]]$type <- "single"
anim.values <- AnimationInfo$timeValues
if(length(AnimationInfo$timeValues)==0){
stop("no interactive aes for time variable ", AnimationInfo$time$variable)
}
anim.not.null <- anim.values[!sapply(anim.values, is.null)]
time.classes <- sapply(anim.not.null, function(x) class(x)[1])
time.class <- time.classes[[1]]
if(any(time.class != time.classes)){
print(time.classes)
stop("time variables must all have the same class")
}
AnimationInfo$time$sequence <- if(time.class=="POSIXct"){
orderTime <- function(format){
values <- unlist(sapply(anim.not.null, strftime, format))
sort(unique(as.character(values)))
}
hms <- orderTime("%H:%M:%S")
f <- if(length(hms) == 1){
"%Y-%m-%d"
}else{
"%Y-%m-%d %H:%M:%S"
}
orderTime(f)
}else if(time.class=="factor"){
levs <- levels(anim.not.null[[1]])
if(any(sapply(anim.not.null, function(f)levels(f)!=levs))){
print(sapply(anim.not.null, levels))
stop("all time factors must have same levels")
}
levs
}else{ #character, numeric, integer, ... what else?
as.character(sort(unique(unlist(anim.not.null))))
}
meta$selectors[[time.var]]$selected <- AnimationInfo$time$sequence[[1]]
}
## The first selection:
for(selector.name in names(meta$first)){
first <- as.character(meta$first[[selector.name]])
if(selector.name %in% names(meta$selectors)){
s.type <- meta$selectors[[selector.name]]$type
if(s.type == "single"){
stopifnot(length(first) == 1)
}
meta$selectors[[selector.name]]$selected <- first
}else{
print(list(selectors=names(meta$selectors),
missing.first=selector.name))
stop("missing first selector variable")
}
}
meta$plots <- AllPlotsInfo
meta$time <- AnimationInfo$time
meta$timeValues <- AnimationInfo$timeValues
export.names <- c(
"geoms", "time", "duration", "selectors", "plots", "title", "source")
export.data <- list()
for(export.name in export.names){
if(export.name %in% ls(meta)){
export.data[[export.name]] <- meta[[export.name]]
}
}
json <- RJSONIO::toJSON(export.data)
cat(json, file = file.path(out.dir, json.file))
if (open.browser) {
if (identical(getOption("animint.browser"),"browseURL")) {
u <- normalizePath(file.path(out.dir, "index.html"))
browseURL(u)
} else {
servr::httd(normalizePath(out.dir,winslash="/"))
}
}
## After everything has been done, we restore the original mappings
## in the plot.list. This is necessary for visualizations where we use
## the same plot.list with minor edits in another viz
## See this comment:
## https://github.com/tdhock/animint2/pull/5#issuecomment-323074518
for(plot_i in ggplot.list){
for(layer_i in seq_along(plot_i$ggplot$layers)){
plot_i$ggplot$layers[[layer_i]]$mapping <-
plot_i$ggplot$layers[[layer_i]]$orig_mapping
}
}
invisible(meta)
### An invisible copy of the R list that was exported to JSON.
}
#' Function to get legend information from ggplot
#' @param plistextra output from ggplot_build(p)
#' @return list containing information for each legend
#' @export
getLegendList <- function(plistextra){
plot <- plistextra$plot
scales <- plot$scales
layers <- plot$layers
default_mapping <- plot$mapping
theme <- plot_theme(plot)
position <- theme$legend.position
text <- theme$legend.text
title <- theme$legend.title
# by default, guide boxes are vertically aligned
if(is.null(theme$legend.box)) theme$legend.box <- "vertical" else theme$legend.box
# size of key (also used for bar in colorbar guide)
if(is.null(theme$legend.key.width)) theme$legend.key.width <- theme$legend.key.size
if(is.null(theme$legend.key.height)) theme$legend.key.height <- theme$legend.key.size
# by default, direction of each guide depends on the position of the guide.
if(is.null(theme$legend.direction)){
theme$legend.direction <-
if (length(position) == 1 && position %in% c("top", "bottom", "left", "right"))
switch(position[1], top =, bottom = "horizontal", left =, right = "vertical")
else
"vertical"
}
# justification of legend boxes
theme$legend.box.just <-
if(is.null(theme$legend.box.just)) {
if (length(position) == 1 && position %in% c("top", "bottom", "left", "right"))
switch(position, bottom =, top = c("center", "top"), left =, right = c("left", "top"))
else
c("center", "center")
}
position <- theme$legend.position
# locate guide argument in scale_*, and use that for a default.
# Note, however, that guides(colour = ...) has precendence! See https://gist.github.com/cpsievert/ece28830a6c992b29ab6
guides.args <- list()
for(aes.name in c("colour", "fill")){
aes.loc <- which(scales$find(aes.name))
guide.type <- if (length(aes.loc) == 1){
scales$scales[[aes.loc]][["guide"]]
}else{
"legend"
}
if(guide.type=="colourbar")guide.type <- "legend"
guides.args[[aes.name]] <- guide.type
}
guides.result <- do.call(guides, guides.args)
guides.list <- plyr::defaults(plot$guides, guides.result)
gdefs <- guides_train(scales = scales,
theme = theme,
guides = guides.list,
labels = plot$labels)
if (length(gdefs) != 0) {
gdefs <- guides_merge(gdefs)
gdefs <- guides_geom(gdefs, layers, default_mapping)
} else (zeroGrob())
names(gdefs) <- sapply(gdefs, function(i) i$title)
## adding the variable used to each LegendList
for(leg in seq_along(gdefs)) {
legend_type <- names(gdefs[[leg]]$key)
legend_type <- legend_type[legend_type != ".label"]
gdefs[[leg]]$legend_type <- legend_type
scale.list <- scales$scales[which(scales$find(legend_type))]
discrete.vec <- sapply(scale.list, inherits, "ScaleDiscrete")
is.discrete <- all(discrete.vec)
gdefs[[leg]]$is.discrete <- is.discrete
gdefs[[leg]]$text_size <- getTextSize("legend.text", theme)
gdefs[[leg]]$title_size <- getTextSize("legend.title", theme)
## get the name of the legend/selection variable.
var.list <- list()
for(layer.i in seq_along(plot$layers)) {
L <- plot$layers[[layer.i]]
var.list[[layer.i]] <- L$mapping[legend_type]
}
unique.var.list <- unique(unlist(var.list))
if(is.discrete){
var.name <- unique.var.list[[1]]
if(length(unique.var.list) == 1 && is.symbol(var.name)){
gdefs[[leg]]$selector <- paste(var.name)
}else{
str(unique.var.list)
stop("need exactly 1 variable name ",
"(not constant, not language/expression) ",
"to create interactive discrete legend for aes ",
paste(legend_type, collapse=", "))
}
}
## do not draw geoms which are constant:
geom.list <- gdefs[[leg]]$geoms
geom.data.list <- lapply(geom.list, "[[", "data")
geom.data.rows <- sapply(geom.data.list, nrow)
geom.unique.list <- lapply(geom.data.list, unique)
geom.unique.rows <- sapply(geom.unique.list, nrow)
is.ignored <- 1 < geom.data.rows & geom.unique.rows == 1
gdefs[[leg]]$geoms <- geom.list[!is.ignored]
## Pass a geom.legend.list to be used by the
## GetLegend function
geom.legend.list <- list()
for(geom.i in seq_along(gdefs[[leg]]$geoms)){
data.geom.i <- gdefs[[leg]]$geoms[[geom.i]]$data
params.geom.i <- gdefs[[leg]]$geoms[[geom.i]]$params
size.geom.i <- gdefs[[leg]]$geoms[[geom.i]]$size
suppressWarnings(draw.key.used <-
gdefs[[leg]]$geoms[[geom.i]]$draw_key(
data.geom.i, params.geom.i, size.geom.i)
)
geom.legend <- class(draw.key.used)[[1]]
geom.legend.list <- c(geom.legend.list, geom.legend)
}
## Process names to be used by the CleanData function
convert.names.list <- list(points="point", segments="path", rect="polygon")
names.to.change <- geom.legend.list %in% names(convert.names.list)
geom.legend.list[names.to.change] <-
convert.names.list[unlist(geom.legend.list[names.to.change])]
gdefs[[leg]]$geom.legend.list <- geom.legend.list
}
## Add a flag to specify whether or not breaks was manually
## specified. If it was, then it should be respected. If not, and
## the legend shows a numeric variable, then it should be reversed.
for(legend.name in names(gdefs)){
key.df <- gdefs[[legend.name]]$key
aes.name <- names(key.df)[1]
scale.i <- which(scales$find(aes.name))
if(length(scale.i) == 1){
sc <- scales$scales[[scale.i]]
gdefs[[legend.name]]$breaks <- sc$breaks
}
}
legend.list <- lapply(gdefs, getLegend)
## Add a flag to specify whether or not there is both a color and a
## fill legend to display. If so, we need to draw the interior of
## the points in the color legend as the same color.
if(1 < length(legend.list)){
is.color <- sapply(legend.list, function(L)"colour" %in% L$legend_type)
is.fill <- sapply(legend.list, function(L)"fill" %in% L$legend_type)
is.point <- sapply(legend.list, function(L)"point" %in% L$geoms)
has.both <- 2 == sum(is.point & (is.color | is.fill))
if(has.both){
for(legend.i in which(is.color)){
entry.list <- legend.list[[legend.i]]$entries
for(entry.i in seq_along(entry.list)){
entry <- entry.list[[entry.i]]
color.names <- grep("colour", names(entry), value=TRUE)
fill.names <- sub("colour", "fill", color.names)
entry[fill.names] <- "#FFFFFF"
legend.list[[legend.i]]$entries[[entry.i]] <- entry
}
}
}
}
legend.list[0 < sapply(legend.list, length)]
}
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.