Permalink
Branch: master
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
242 lines (238 sloc) 9.44 KB
#' Define how entering and exiting data behaves
#'
#' The purpose of `enter_*()` and `exit_*()` is to control what happens with
#' data that does not persist during a tween. In general the non-persistent data
#' is transformed to an *invisible* version that can be tweened to, e.g. by
#' setting the opacity to 0 or be moving the element off-screen. It is possible
#' to define your own transformations, or rely on some of the build in
#' *effects*.
#'
#' @param early Should the data appear in the beginning of the transition or in
#' the end
#' @param alpha The start/end transparency.
#' @param colour,color,fill The start/end colour and fill the elements should
#' (dis)appear into
#' @param x_loc,y_loc Start and end positions of the graphic elements
#' @param x_mod,y_mod Modification to add to the entering or exiting data
#' @param size The proportional start/end size. `0` means complete shrinking
#' while `1` means no shrinking
#' @param default A default transformation to use
#' @param name A name for the manual modification (only used when printing the
#' object)
#' @param ... Additional specific transformations either named by the geom
#' (e.g. `bar`, or by its position in the layer stack, e.g. `"2"`)
#'
#' @section User-defined transformations:
#' All enter/exit functions allows the user to add additional transformation
#' functions targeting specific layers. If the functions are named, then the
#' name is understood to reference the class of geoms it applies to. If the
#' functions are unnamed or numbered they will apply to the layer with a
#' matching index in the stack. Named and indexed transformations cannot be
#' mixed.
#'
#' All modifications except `enter_manual()`/`exit_manual()` sets a range of
#' modifications already, but further can be added with the `...`. For the
#' manual versions a `default` transformation can be set which will apply to all
#' layers that does not match any of the other given transformations. Often a
#' single default transformation is enough and no specific transformations are
#' needed.
#'
#' Transformation can be given as any expression that can be converted with
#' [rlang::as_function()]. This means that `purrr` style lambda functions are
#' allowed in addition to anonymous functions etc. Transformation functions must
#' accept a data.frame and return a data.frame of the same dimensions. The
#' function will be called with the entering/exiting layer data, except for the
#' case of polygon- and path-like layers in which case the function recieves the
#' entering/exiting polygon/path data one by one. A special option is to set a
#' transformation as `NULL` instead of a function. In that case the entering and
#' exiting data will simply appear/disappear when it is no longer part of a
#' frame.
#'
#' @section Modification composition:
#' Enter and exit modifications are composable so that multiple different ones
#' can be added to an animation and will be applied in turn. You can also
#' combine multiples and save them as a new enter or exit modification using
#' `c()`.
#'
#' Due to the composable nature of enter and exit modifications it is not
#' possible to overwrite a prior modification by adding a new. If it is needed
#' to start from scratch then the sentinels `enter_reset()` and `exit_reset()`
#' are provided which clears all prior modifications.
#'
#' @section Modification types:
#' A range of modification types are provided by `gganimate` and using
#' `enter_manual()`/`exit_manual()` or modification composition it is possible
#' to create your own.
#'
#' **appear**/**disappear** will simply make elements appear/disappear at either
#' the start or end of the transition. The default if nothing else is added.
#'
#' **fade** will simply set the alpha value to zero making the elements fade
#' in/out during the transition.
#'
#' **grow**/**shrink** will set the elements to zero size making them gradually
#' grow into / shrink out of existence. Zero size depends on the type of layer,
#' e.g. polygons/paths will have all their points set to the mean, while points
#' will have size/stroke set to zero.
#'
#' **recolour**/**recolor** will change the colour and/or fill of the elements
#' making them gradually change from the defined colour and into their try
#' colour. Be aware that unless the colour and fill are set to the same as the
#' background colour of the plot this modification needs to be combined with
#' others to ensure that elements does not abruptly appear.
#'
#' **fly** will set a specific x and y position where all elements will enter
#' from/ exit to, irrespectible of their real position.
#'
#' **drift** will modify the real position of the entering and exiting elements
#' by a specified amount, e.g. setting `x_mod = -5` will let all elements enter
#' from/exit to the left with a terminal position 5 points to the left of the
#' real position.
#'
#' @name enter_exit
#' @rdname enter_exit
#' @aliases enter exit
#'
#' @examples
#' # Default is appear/disappear
#' anim <- ggplot(mtcars, aes(factor(gear), mpg)) +
#' geom_boxplot() +
#' transition_states(gear, 2, 1)
#'
#' # Fade-in, fly-out
#' anim1 <- anim +
#' enter_fade() +
#' exit_fly(x_loc = 7, y_loc = 40)
#'
#' # Enter and exit accumulates
#' anim2 <- anim +
#' enter_fade() + enter_grow() +
#' exit_fly(x_loc = 7, y_loc = 40) + exit_recolour(fill = 'forestgreen')
#'
NULL
#' @importFrom ggplot2 ggproto
create_factory <- function(type, default, ..., name = 'manual') {
fac_class <- switch(type, enter = 'EnterFactory', exit = 'ExitFactory')
factories <- prepare_factories(default, ...)
ggproto(fac_class, TransmuteFactory,
factory_layer = list(list(
default = factories$default,
positions = factories$positions,
classes = factories$classes
)),
name = name
)
}
create_resetter <- function(type) {
fac_class <- switch(type, enter = 'EnterFactory', exit = 'ExitFactory')
ggproto(fac_class, TransmuteFactory, reset = TRUE)
}
#' @importFrom ggplot2 ggproto
TransmuteFactory <- ggproto('TransmuteFactory', NULL,
factory_layer = list(),
name = '',
reset = FALSE,
print = function(self, ...) {
cat('<', class(self)[1], if (self$reset) ' (Resetter)' else '', '>\n', sep = '')
if (!self$reset) cat(' Stages: ', paste(self$name, collapse = ', '), '\n', sep = '')
invisible(self)
},
add_factory = function(self, x) {
if (!self$inherit(x)) stop("Can only combine factories of same class", call. = FALSE)
if (x$reset) {
self$factory_layer <- list()
self$name <- character()
self$reset <- TRUE
} else {
self$factory_layer <- c(self$factory_layer, x$factory_layer)
self$name <- c(self$name, x$name)
self$reset <- FALSE
}
invisible(self)
},
inherit = function(self, x) {
inherits(x, class(self)[1])
},
get_factories = function(self, layers) {
f_layers <- lapply(self$factory_layer, function(f_layer) {
if (length(f_layer$positions) != 0) {
factories <- rep(list(f_layer$default), length(layers))
factories[as.integer(names(f_layer$positions))] <- f_layer$positions
} else if (length(f_layer$classes) != 0) {
lapply(layers, function(l) {
best <- inherits(l$geom, names(f_layer$classes), which = TRUE)
if (all(best == 0)) {
f_layer$default
} else {
best <- which(best != 0 & best == min(best[best != 0]))
f_layer$classes[[best[1]]]
}
})
} else {
rep(list(f_layer$default), length(layers))
}
})
lapply(seq_along(layers), function(i) {
factory_line <- lapply(f_layers, `[[`, i)
if (any(vapply(factory_line, is.null, logical(1)))) return(NULL)
function(x) {
for (i in seq_along(factory_line)) {
x <- factory_line[[i]](x)
}
x
}
})
},
clone = function(self) {
ggproto(NULL, self)
}
)
#' @export
c.TransmuteFactory <- function(...) {
factories <- list(...)
if (length(factories) == 1) return(factories)
factories[[1]] <- factories[[1]]$clone()
Reduce(function(l, r) l$add_factory(r), factories)
}
#' @export
#' @importFrom ggplot2 ggplot_add
ggplot_add.EnterFactory <- function(object, plot, object_name) {
plot <- as.gganim(plot)
plot$transmuters <- plot$transmuters$clone()
plot$transmuters$add_enter(object)
plot
}
#' @export
#' @importFrom ggplot2 ggplot_add
ggplot_add.ExitFactory <- function(object, plot, object_name) {
plot <- as.gganim(plot)
plot$transmuters <- plot$transmuters$clone()
plot$transmuters$add_exit(object)
plot
}
# HELPERS -----------------------------------------------------------------
#' @importFrom rlang as_function
maybe_function <- function(x) if (is.null(x)) x else as_function(x)
capitalise <- function(x) {
x1 <- substring(x, 1L, 1L)
if (nchar(x) >= 3L && x1 %in% c("'", "\""))
paste0(x1, toupper(substring(x, 2L, 2L)), tolower(substring(x, 3L)))
else paste0(toupper(x1), tolower(substring(x, 2L)))
}
prepare_factories <- function(default, ...) {
default <- maybe_function(default)
specials <- lapply(list(...), maybe_function)
positions <- list()
classes <- list()
if (length(specials) != 0) {
if (all(grepl('^\\d+$', names(specials)))) {
if (is.null(names(specials))) names(specials) <- as.character(seq_along(specials))
positions = specials
} else {
geoms <- sub('geom_?', '', names(specials), ignore.case = TRUE)
names(specials) <- paste0('Geom', vapply(tolower(geoms), capitalise, character(1)))
classes <- specials
}
}
list(default = default, positions = positions, classes = classes)
}