Permalink
Switch branches/tags
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
351 lines (311 sloc) 15 KB
#' @title Animate cases on a process map
#'
#' @description A function for creating a SVG animation of an event log on a process map created by \code{\link{process_map}} from the processmapR package.
#'
#' @param eventlog The event log object that should be animated
#' @param processmap The process map created with processmapR that the event log should be animated on,
#' if not provided a standard process map will be generated by using processmapR::process_map.
#' @param renderer Whether to use Graphviz (\code{\link{renderer_graphviz}}) to layout and render the process map,
#' or to render the process map using Leaflet ((\code{\link{renderer_leaflet}})) on a geographical map.
#' @param mode Whether to animate the cases according to their actual time of occurence ("absolute") or to start all cases at once ("relative").
#' @param duration The overall duration of the animation, all times are scaled according to this overall duration.
#' @param jitter The magnitude of a random coordinate translation, known as jitter in scatterplots, which is added to each token.
#' Adding jitter can help to disambiguate tokens traveling on top of each other.
#' @param timeline Whether to render a timeline slider in supported browsers (Recent versions of Chrome and Firefox only).
#' @param legend Whether to show a legend for the `size` or the `color`` scale.
#' @param repeat_count The number of times the process animation is repeated.
#' @param repeat_delay The seconds to wait before one repetition of the animation.
#' @param epsilon_time A (small) time to be added to every animation to ensure that tokens are visible.
#' @param mapping A list of aesthetic mappings from event log attributes to certain visual parameters of the tokens.
#' Use \code{\link{token_aes}} to create a suitable mapping list.
#' @param token_callback_onclick A JavaScript function that is called when a token is clicked.
#' The function is parsed by \code{\link{JS}} and received three parameters: 'svg_root', 'svg_element', and 'case_id'.
#' @param token_callback_select A JavaScript callback function called when token selection changes.
#' @param activity_callback_onclick A JavaScript function that is called when an activity is clicked.
#' The function is parsed by \code{\link{JS}} and received three parameters: 'svg_root', 'svg_element', and 'activity_id'.
#' @param activity_callback_select A JavaScript callback function called when activity selection changes.
#' @param elementId passed through to \code{\link{createWidget}}. A custom elementId is useful to capture the selection events
#' via input$elementId_tokens and input$elementId_activities when used in Shiny.
#' @param preRenderHook passed through to \code{\link{createWidget}}.
#' @param width,height Fixed size for widget (in css units).
#' The default is NULL, which results in intelligent automatic sizing based on the widget's container.
#' @param ... Options passed on to \code{\link{process_map}}.
#'
#' @examples
#' data(example_log)
#'
#' # Animate the process with default options (absolute time and 60s duration)
#' animate_process(example_log)
#' \donttest{
#' # Animate the process with default options (relative time, with jitter, infinite repeat)
#' animate_process(example_log, mode = "relative", jitter = 10, repeat_count = Inf)
#' }
#'
#' @seealso \code{\link{process_map}}, \code{\link{token_aes}}
#'
#' @import dplyr
#' @import bupaR
#' @import processmapR
#' @importFrom magrittr %>%
#' @importFrom rlang :=
#' @importFrom rlang !!
#'
#' @export
animate_process <- function(eventlog, processmap = process_map(eventlog, render = F, ...),
renderer = renderer_graphviz(),
mode = c("absolute","relative","off"),
duration = 60,
jitter = 0,
timeline = TRUE,
legend = NULL,
repeat_count = 1,
repeat_delay = 0.5,
epsilon_time = duration / 1000,
mapping = token_aes(),
token_callback_onclick = c("function(svg_root, svg_element, case_id) {","}"),
token_callback_select = token_select_decoration(),
activity_callback_onclick = c("function(svg_root, svg_element, activity_id) {","}"),
activity_callback_select = activity_select_decoration(),
elementId = NULL,
preRenderHook = NULL,
width = NULL,
height = NULL,
...) {
if (any(startsWith(as.character(names(list(...))), "animation_"))) {
stop("The old pre 1.0 API using `animation_` parameters is deprecated.")
}
# Make CRAN happy about dplyr evaluation
case_start <- log_end <- start_time <- end_time <- next_end_time <- next_start_time <- NULL
case <- case_end <- log_start <- log_duration <- case_duration <- from_id <- to_id <- NULL
label <- act <- NULL
token_start <- token_end <- activity_duration <- token_duration <- NULL
mode <- match.arg(mode)
precedence <- attr(processmap, "base_precedence") %>%
mutate_at(vars(start_time, end_time, next_start_time, next_end_time), as.numeric, units = "secs")
if (mode != "off") {
cases <- precedence %>%
group_by(case) %>%
filter(!is.na(case)) %>%
summarise(case_start = min(start_time, na.rm = T),
case_end = max(end_time, na.rm = T)) %>%
mutate(case_duration = case_end - case_start) %>%
ungroup()
# determine animation factor based on requested duration
if (mode == "absolute") {
timeline_start <- cases %>% pull(case_start) %>% min(na.rm = T)
timeline_end <- cases %>% pull(case_end) %>% max()
a_factor <- (timeline_end - timeline_start) / duration
} else {
timeline_start <- 0
timeline_end <- cases %>% pull(case_duration) %>% max(na.rm = T)
a_factor = timeline_end / duration
}
tokens <- generate_tokens(cases, precedence, processmap, mode, a_factor,
timeline_start, timeline_end, epsilon_time)
adjust <- max(tokens$token_end) / duration
tokens <- tokens %>%
mutate(token_start = token_start / adjust,
token_duration = token_duration / adjust,
activity_duration = activity_duration / adjust) %>%
select(-token_end)
sizes <- generate_animation_attribute(eventlog, mapping$size$attribute, 6)
sizes <- transform_time(sizes, cases, mode, a_factor, timeline_start, timeline_end)
colors <- generate_animation_attribute(eventlog, mapping$color$attribute, "white")
colors <- transform_time(colors, cases, mode, a_factor, timeline_start, timeline_end)
images <- generate_animation_attribute(eventlog, mapping$image$attribute, NA)
images <- transform_time(images, cases, mode, a_factor, timeline_start, timeline_end)
if (mapping$shape == "image" && nrow(images) == 0) {
stop("Need to supply image URLs in parameter 'mapping' to use shape 'image'.");
}
opacities <- generate_animation_attribute(eventlog, mapping$opacity$attribute, 0.9)
opacities <- transform_time(opacities, cases, mode, a_factor, timeline_start, timeline_end)
} else {
# No animation mode, for using activity selection features only
sizes <- data.frame()
colors <- data.frame()
images <- data.frame()
opacities <- data.frame()
tokens <- data.frame()
timeline_start <- 0
timeline_end <- 0
timeline <- FALSE
a_factor <- 0
}
start_activity <- processmap$nodes_df %>% filter(label == "Start") %>% pull(id)
end_activity <- processmap$nodes_df %>% filter(label == "End") %>% pull(id)
activities <- precedence %>%
select(act, id = from_id) %>%
stats::na.omit() %>%
distinct() %>%
arrange(id)
# actually render the process
rendered_process <- renderer(processmap, width, height)
settings <- list()
x <- list(
rendered_process = rendered_process,
activities = activities,
tokens = tokens,
sizes = sizes,
sizes_scale = mapping$size,
colors = colors,
colors_scale = mapping$color,
opacities = opacities,
opacities_scale = mapping$opacity,
images = images,
images_scale = mapping$image,
shape = mapping$shape, #TODO see if this can be a scale too
attributes = mapping$attributes,
start_activity = start_activity,
end_activity = end_activity,
duration = duration,
timeline = timeline,
mode = mode,
repeat_count = repeat_count,
repeat_delay = repeat_delay,
jitter = jitter,
factor = a_factor * 1000,
legend = legend,
timeline_start = timeline_start * 1000,
timeline_end = timeline_end * 1000,
onclick_token_callback = htmlwidgets::JS(token_callback_onclick),
onclick_token_select = htmlwidgets::JS(token_callback_select),
onclick_activity_callback = htmlwidgets::JS(activity_callback_onclick),
onclick_activity_select = htmlwidgets::JS(activity_callback_select),
processmap_renderer = attr(renderer, "name")
)
htmlwidgets::createWidget(elementId = elementId,
name = "processanimateR", x = x,
width = width, height = height,
sizingPolicy = htmlwidgets::sizingPolicy(
defaultWidth = 800,
defaultHeight = 600,
knitr.figure = FALSE,
knitr.defaultWidth = 700,
knitr.defaultHeight = 400,
browser.fill = TRUE
),
preRenderHook = preRenderHook)
}
#' @title Create a process animation output element
#' @description Renders a renderProcessanimater within an application page.
#' @param outputId Output variable to read the animation from
#' @param width,height Must be a valid CSS unit (like 100%, 400px, auto) or a number,
#' which will be coerced to a string and have px appended.
#'
#' @export
processanimaterOutput <- function(outputId, width = "100%", height = "400px") {
htmlwidgets::shinyWidgetOutput(outputId = outputId,
name = "processanimateR",
inline = F,
width = width, height = height,
package = "processanimateR")
}
#' @title Renders process animation output
#' @description Renders a SVG process animation suitable to be used by processanimaterOutput.
#' @param expr The expression generating a process animation (animate_process).
#' @param env The environment in which to evaluate expr.
#' @param quoted Is expr a quoted expression (with quote())? This is useful if you want to save an expression in a variable.
#'
#' @export
renderProcessanimater <- function(expr, env = parent.frame(), quoted = FALSE) {
if (!quoted) { expr <- substitute(expr) } # force quoted
htmlwidgets::shinyRenderWidget(expr, processanimaterOutput, env, quoted = TRUE)
}
#
# Private helper functions
#
generate_tokens <- function(cases, precedence, processmap, mode, a_factor,
timeline_start, timeline_end, epsilon) {
case <- end_time <- start_time <- next_end_time <- next_start_time <- case_start <- token_duration <- NULL
min_order <- token_start <- activity_duration <- token_end <- from_id <- to_id <- case_duration <- NULL
tokens <- precedence %>%
left_join(cases, by = c("case")) %>%
left_join(processmap$edges_df, by = c("from_id" = "from", "to_id" = "to")) %>%
filter(!is.na(id) & !is.na(case))
if (mode == "absolute") {
tokens <- mutate(tokens,
token_start = (end_time - timeline_start) / a_factor,
token_duration = (next_start_time - end_time) / a_factor,
activity_duration = pmax(0, (next_end_time - next_start_time) / a_factor))
} else {
tokens <- mutate(tokens,
token_start = (end_time - case_start) / a_factor,
token_duration = (next_start_time - end_time) / a_factor,
activity_duration = pmax(0, (next_end_time - next_start_time) / a_factor))
}
tokens <- tokens %>%
# TODO improve handling of parallelism
# Filter all negative durations caused by parallelism
filter(token_duration >= 0, activity_duration >= 0) %>%
# SVG animations seem to not like events starting at the same time caused by 0s durations
mutate(token_duration = epsilon + token_duration,
activity_duration = epsilon + activity_duration) %>%
arrange(case, start_time, min_order) %>%
group_by(case) %>%
# Ensure start times are not overlapping SMIL does not fancy this
mutate(token_start = token_start + ((row_number(token_start) - min_rank(token_start)) * epsilon)) %>%
# Ensure consecutive start times, this epsilon just needs to be small
mutate(token_end = min(token_start) + cumsum(token_duration + activity_duration) + 0.000001) %>%
mutate(token_start = lag(token_end, default = min(token_start))) %>%
ungroup()
tokens %>%
select(case,
edge_id = id,
token_start,
token_duration,
activity_duration,
token_end)
}
generate_animation_attribute <- function(eventlog, value, default) {
attribute <- rlang::sym("value")
if (is.null(value)) {
# use default
eventlog %>%
as.data.frame() %>%
mutate(!!attribute := default) %>%
select(case = !!case_id_(eventlog),
time = !!timestamp_(eventlog),
!!attribute)
} else if (is.data.frame(value)) {
# check data present
stopifnot(c("case", "time", "value") %in% colnames(value))
value
} else if (value %in% colnames(eventlog)) {
# use existing value from event log
eventlog %>%
as.data.frame() %>%
mutate(!!attribute := !!rlang::sym(value)) %>%
select(case = !!case_id_(eventlog),
time = !!timestamp_(eventlog),
!!attribute)
} else {
# set to a fixed value
eventlog %>%
as.data.frame() %>%
mutate(!!attribute := value) %>%
select(case = !!case_id_(eventlog),
time = !!timestamp_(eventlog),
!!attribute)
}
}
transform_time <- function(data, cases, mode, a_factor, timeline_start, timeline_end) {
.order <- time <- case <- log_start <- case_start <- NULL
col <- rlang::sym("value")
data <- data %>%
group_by(case) %>%
filter(row_number() == 1 | lag(!!col) != !!col) %>% # only keep changes in value
left_join(cases, by = "case")
if (mode == "absolute") {
data <- data %>%
mutate(time = as.numeric(time - timeline_start, units = "secs") / a_factor) %>%
select(case, time, !!col)
} else {
col <- data %>%
mutate(time = as.numeric(time - case_start, units = "secs") / a_factor) %>%
select(case, time, !!col)
}
}
# Utility functions
# https://github.com/gertjanssenswillen/processmapR/blob/master/R/utils.R
case_id_ <- function(eventlog) rlang::sym(case_id(eventlog))
timestamp_ <- function(eventlog) rlang::sym(timestamp(eventlog))