diff --git a/.Rbuildignore b/.Rbuildignore index ea7e45a..763739c 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -10,3 +10,4 @@ ^inst/htmlwidgets/lib/d3/node_modules/ ^inst/htmlwidgets/lib/leaflet/node_modules/ ^cran-comments\.md$ +^\.github$ diff --git a/.github/.gitignore b/.github/.gitignore new file mode 100644 index 0000000..2d19fc7 --- /dev/null +++ b/.github/.gitignore @@ -0,0 +1 @@ +*.html diff --git a/.github/workflows/check-standard.yaml b/.github/workflows/check-standard.yaml new file mode 100644 index 0000000..d7877b7 --- /dev/null +++ b/.github/workflows/check-standard.yaml @@ -0,0 +1,86 @@ +# For help debugging build failures open an issue on the RStudio community with the 'github-actions' tag. +# https://community.rstudio.com/new-topic?category=Package%20development&tags=github-actions +on: + push: + branches: + - dev + - master + pull_request: + branches: + - dev + - master + +name: R-CMD-check + +jobs: + R-CMD-check: + runs-on: ${{ matrix.config.os }} + + name: ${{ matrix.config.os }} (${{ matrix.config.r }}) + + strategy: + fail-fast: false + matrix: + config: + - {os: windows-latest, r: 'release'} + - {os: macOS-latest, r: 'release'} + - {os: ubuntu-20.04, r: 'release', rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"} + - {os: ubuntu-20.04, r: 'devel', rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"} + + env: + R_REMOTES_NO_ERRORS_FROM_WARNINGS: true + RSPM: ${{ matrix.config.rspm }} + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + + steps: + - uses: actions/checkout@v2 + + - uses: r-lib/actions/setup-r@v1 + with: + r-version: ${{ matrix.config.r }} + + - uses: r-lib/actions/setup-pandoc@v1 + + - name: Query dependencies + run: | + install.packages('remotes') + saveRDS(remotes::dev_package_deps(dependencies = TRUE), ".github/depends.Rds", version = 2) + writeLines(sprintf("R-%i.%i", getRversion()$major, getRversion()$minor), ".github/R-version") + shell: Rscript {0} + + - name: Cache R packages + if: runner.os != 'Windows' + uses: actions/cache@v2 + with: + path: ${{ env.R_LIBS_USER }} + key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }} + restore-keys: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1- + + - name: Install system dependencies + if: runner.os == 'Linux' + run: | + while read -r cmd + do + eval sudo $cmd + done < <(Rscript -e 'writeLines(remotes::system_requirements("ubuntu", "20.04"))') + + - name: Install dependencies + run: | + remotes::install_deps(dependencies = TRUE) + remotes::install_cran("rcmdcheck") + shell: Rscript {0} + + - name: Check + env: + _R_CHECK_CRAN_INCOMING_REMOTE_: false + run: | + options(crayon.enabled = TRUE) + rcmdcheck::rcmdcheck(args = c("--no-manual", "--as-cran"), error_on = "warning", check_dir = "check") + shell: Rscript {0} + + - name: Upload check results + if: failure() + uses: actions/upload-artifact@main + with: + name: ${{ runner.os }}-r${{ matrix.config.r }}-results + path: check diff --git a/.gitignore b/.gitignore index bfb2f7f..f7d00af 100644 --- a/.gitignore +++ b/.gitignore @@ -30,3 +30,5 @@ inst/doc inst/htmlwidgets/lib/d3/node_modules/ inst/htmlwidgets/lib/leaflet/node_modules/ cran-comments.md +/doc/ +/Meta/ diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index 824a342..0000000 --- a/.travis.yml +++ /dev/null @@ -1,17 +0,0 @@ -# R for travis: see documentation at https://docs.travis-ci.com/user/languages/r - -dist: xenial -language: R -sudo: false -addons: - apt: - packages: - - libnode-dev -r: - - oldrel - - release - - devel -r_packages: - - DiagrammeRsvg -cache: packages -latex: false diff --git a/DESCRIPTION b/DESCRIPTION index c736336..7831e9c 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -2,7 +2,7 @@ Package: processanimateR Type: Package Title: Process Map Token Replay Animation Version: 1.1.0.9000 -Authors@R: c(person("Felix","Mannhardt", email = "felix.mannhardt@sintef.no", role = c("aut","cre")), +Authors@R: c(person("Felix","Mannhardt", email = "felix.mannhardt@tue.nl", role = c("aut","cre")), person("Gert","Janssenswillen",email = "gert.janssenswillen@uhasselt.be", role = c("ctb"))) Description: Provides animated process maps based on the 'procesmapR' package. Cases stored in event logs created with with 'bupaR' S3 class eventlog() are @@ -35,7 +35,7 @@ Suggests: shiny, RColorBrewer, lubridate -RoxygenNote: 7.1.0 +RoxygenNote: 7.1.1 URL: https://github.com/bupaverse/processanimateR/ BugReports: https://github.com/bupaverse/processanimateR/issues VignetteBuilder: knitr diff --git a/NAMESPACE b/NAMESPACE index f4bb534..a5d9e40 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,5 +1,7 @@ # Generated by roxygen2: do not edit by hand +export(activity_aes) +export(activity_scale) export(activity_select_decoration) export(animate_process) export(attribution_osm) diff --git a/R/token_aes.R b/R/aesthetics.R similarity index 56% rename from R/token_aes.R rename to R/aesthetics.R index 3cdf63b..76a666c 100644 --- a/R/token_aes.R +++ b/R/aesthetics.R @@ -1,3 +1,43 @@ +#' @title Activity aesthetics mapping +#' +#' @param color The scale used for the activity color, +#' @param linecolor The scale used for the activity color, +#' @param opacity The scale used for the activity opacity. +#' @param label The scale used for the additional activity label. Usually an `identity` scale makes sense here. +#' @param attributes A list of additional (fixed - non changing) SVG attributes to be added to each activity. +#' +#' @return An aesthetics mapping for `animate_process`. +#' @export +#' +#' @examples +#' data(example_log) +#' library(eventdataR) +#' animate_process(patients, +#' mode = "absolute", +#' legend = "act_color", +#' duration = 300, +#' mapping_activity = +#' activity_aes(color = activity_scale("employee", scale = "ordinal", +#' range = c("red", "green", "blue", "yellow")), +#' linecolor = activity_scale("time", scale = "time", +#' range = c("white", "black")), +#' opacity = activity_scale("time", scale = "time", range = c(0.3, 1.0)), +#' label = activity_scale("employee", scale = "identity"))) +#' +#' +#' @seealso \code{\link{animate_process}}, \code{\link{activity_scale}} +#' +activity_aes <- function(color = activity_scale(), + linecolor = activity_scale(), + opacity = activity_scale(), + label = activity_scale(), + attributes = list()) { + + return(c(as.list(environment()))) + +} + + #' @title Tokens aesthetics mapping #' #' @param size The scale used for the token size. diff --git a/R/processanimateR.R b/R/processanimateR.R index 294574a..b1ca0f8 100644 --- a/R/processanimateR.R +++ b/R/processanimateR.R @@ -24,6 +24,8 @@ #' @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 mapping_activity A list of aesthetic mappings from event log attributes to certain visual parameters of the activities +#' Use \code{\link{activity_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. @@ -73,6 +75,7 @@ animate_process <- function(eventlog, repeat_delay = 0.5, epsilon_time = duration / 1000, mapping = token_aes(), + mapping_activity = activity_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) {","}"), @@ -153,6 +156,10 @@ animate_process <- function(eventlog, a_factor = timeline_end / duration } + # + # Token animation + # + tokens <- generate_tokens(cases, precedence, processmap, mode, a_factor, timeline_start, timeline_end, epsilon_time) @@ -164,21 +171,37 @@ animate_process <- function(eventlog, 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) + sizes <- generate_token_animation_attribute(eventlog, mapping$size$attribute, 6) + sizes <- transform_token_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) + colors <- generate_token_animation_attribute(eventlog, mapping$color$attribute, "white") + colors <- transform_token_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) + images <- generate_token_animation_attribute(eventlog, mapping$image$attribute, NA) + images <- transform_token_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) + opacities <- generate_token_animation_attribute(eventlog, mapping$opacity$attribute, 0.9) + opacities <- transform_token_time(opacities, cases, mode, a_factor, timeline_start, timeline_end) + + # + # Activity animation + # + + act_colors <- generate_activity_animation_attribute(eventlog, mapping_activity$color$attribute, NA_character_) + act_colors <- transform_activity_time(act_colors, mode, a_factor, timeline_start, timeline_end) + + act_linecolors <- generate_activity_animation_attribute(eventlog, mapping_activity$linecolor$attribute, NA_character_) + act_linecolors <- transform_activity_time(act_linecolors, mode, a_factor, timeline_start, timeline_end) + + act_opacities <- generate_activity_animation_attribute(eventlog, mapping_activity$opacity$attribute, NA_real_) + act_opacities <- transform_activity_time(act_opacities, mode, a_factor, timeline_start, timeline_end) + + act_labels <- generate_activity_animation_attribute(eventlog, mapping_activity$label$attribute, NA_real_) + act_labels <- transform_activity_time(act_labels, mode, a_factor, timeline_start, timeline_end) } else { # No animation mode, for using activity selection features only @@ -187,6 +210,11 @@ animate_process <- function(eventlog, images <- data.frame() opacities <- data.frame() tokens <- data.frame() + + act_colors <- data.frame() + act_linecolors <- data.frame() + act_opacities <- data.frame() + timeline_start <- 0 timeline_end <- 0 timeline <- FALSE @@ -194,15 +222,20 @@ animate_process <- function(eventlog, } if ("weight" %in% colnames(processmap$edges_df)) { - # hack to add 'weight' attribute to the graph - processmap$edges_df %>% - mutate(len = weight) -> processmap$edges_df + # hack to add 'weight' attribute to the graph + processmap$edges_df %>% + mutate(len = weight) -> processmap$edges_df } if ("constraint" %in% colnames(processmap$edges_df)) { - # hack to add 'weight' attribute to the graph - processmap$edges_df %>% - mutate(decorate = constraint) -> processmap$edges_df + # hack to add 'weight' attribute to the graph + processmap$edges_df %>% + mutate(decorate = constraint) -> processmap$edges_df + } + + if (any(!is.na(act_labels$value))) { + processmap$nodes_df %>% # + mutate(label = if_else(label == "Start" | label == "End", label, paste0(label, '\n '))) -> processmap$nodes_df } # actually render the process map @@ -210,8 +243,15 @@ animate_process <- function(eventlog, x <- list( rendered_process = rendered_process, + activities = activities, + start_activity = start_activity, + end_activity = end_activity, + + # Tokens and their timing tokens = tokens, + + # Additional token aesthetics sizes = sizes, sizes_scale = mapping$size, colors = colors, @@ -220,22 +260,38 @@ animate_process <- function(eventlog, opacities_scale = mapping$opacity, images = images, images_scale = mapping$image, - shape = mapping$shape, #TODO see if this can be a scale too + + #TODO see if this can be a scale too + shape = mapping$shape, attributes = mapping$attributes, - start_activity = start_activity, - end_activity = end_activity, + + act_colors = act_colors, + act_colors_scale = mapping_activity$color, + + act_linecolors = act_linecolors, + act_linecolors_scale = mapping_activity$linecolor, + + act_opacities = act_opacities, + act_opacities_scale = mapping_activity$opacity, + + act_labels = act_labels, + duration = duration, timeline = timeline, mode = mode, + initial_state = initial_state, initial_time = initial_time, 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), @@ -280,119 +336,3 @@ 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 fixed default value - eventlog %>% - as.data.frame() %>% - group_by(!!case_id_(eventlog)) %>% - summarise(time = min(!!timestamp_(eventlog))) %>% - mutate(!!attribute := default) %>% - rename(case = !!case_id_(eventlog)) - } 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 <- value <- NULL - - if (nrow(data) != nrow(cases)) { - data <- data %>% - group_by(case) %>% - filter(row_number() == 1 | lag(value) != value) # only keep changes in value - } - - data <- data %>% - left_join(cases, by = "case") - - if (mode == "absolute") { - data <- mutate(data, time = as.numeric(time - timeline_start, units = "secs")) - } else { - data <- mutate(data, time = as.numeric(time - case_start, units = "secs")) - } - - data %>% - mutate(time = time / a_factor) %>% - select(case, time, value) -} - -# Utility functions -# https://github.com/gertjanssenswillen/processmapR/blob/master/R/utils.R -case_id_ <- function(eventlog) rlang::sym(bupaR::case_id(eventlog)) -timestamp_ <- function(eventlog) rlang::sym(bupaR::timestamp(eventlog)) diff --git a/R/scale.R b/R/scale.R index f4df4f1..961a65d 100644 --- a/R/scale.R +++ b/R/scale.R @@ -1,3 +1,37 @@ + +#' @title Activity scale mapping values to aesthetics +#' +#' @description Creates a `list` of parameters suitable to be used as activity scale in (\code{\link{activity_aes}}) for mapping values to certain aesthetics of the activity in a process map animation. +#' Refer to the d3-scale documentation (https://github.com/d3/d3-scale) for more information about how to set `domain` and `range` properly. +#' +#' @param attribute This may be (1) the name of the event attribute to be used as values, +#' (2) a data frame with three columns (act, time, value) in which the values in the act column are matching the activity identifier of the supplied event log, or +#' (3) a constant value that does not change over time. +#' @param scale Which D3 scale function to be used out of `identity`, `linear`, `sqrt`, `log`, `quantize`, `ordinal`, or `time`. +#' @param domain The domain of the D3 scale function. Can be left NULL in which case it will be automatically determined based on the values. +#' @param range The range of the D3 scale function. Should be a vector of two or more numerical values. +#' +#' @return A scale to be used with `mapping_activity` +#' @export +#' +#' @examples +#' data(example_log) +#' +#' +#' @seealso \code{\link{animate_process}}, \code{\link{activity_aes}} +#' +activity_scale <- function(attribute = NULL, + scale = c("identity", "linear", "sqrt", "log", "quantize", "ordinal", "time"), + domain = NULL, + range = NULL) { + + scale <- match.arg(scale) + + return(c(as.list(environment()))) + +} + + #' @title Token scale mapping values to aesthetics #' #' @description Creates a `list` of parameters suitable to be used as token scale in (\code{\link{token_aes}}) for mapping values to certain aesthetics of the tokens in a process map animation. @@ -10,7 +44,7 @@ #' @param domain The domain of the D3 scale function. Can be left NULL in which case it will be automatically determined based on the values. #' @param range The range of the D3 scale function. Should be a vector of two or more numerical values. #' -#' @return A scale to be used with `token_mapping` +#' @return A scale to be used with `mapping` #' @export #' #' @examples diff --git a/R/utils.R b/R/utils.R new file mode 100644 index 0000000..45d941c --- /dev/null +++ b/R/utils.R @@ -0,0 +1,174 @@ +# +# 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) + +} + +# outputs a data frame: { case, time, attribute/value } +generate_token_animation_attribute <- function(eventlog, value, default) { + attribute <- rlang::sym("value") + if (is.null(value)) { + # use fixed default value + eventlog %>% + as.data.frame() %>% + group_by(!!case_id_(eventlog)) %>% + summarise(time = min(!!timestamp_(eventlog))) %>% + mutate(!!attribute := default) %>% + rename(case = !!case_id_(eventlog)) + } 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_token_time <- function(data, cases, mode, a_factor, timeline_start, timeline_end) { + + .order <- time <- case <- log_start <- case_start <- value <- NULL + + if (nrow(data) != nrow(cases)) { + data <- data %>% + group_by(case) %>% + filter(row_number() == 1 | lag(value) != value) # only keep changes in value + } + + data <- data %>% + left_join(cases, by = "case") + + if (mode == "absolute") { + data <- mutate(data, time = as.numeric(time - timeline_start, units = "secs")) + } else { + data <- mutate(data, time = as.numeric(time - case_start, units = "secs")) + } + + data %>% + mutate(time = time / a_factor) %>% + select(case, time, value) +} + +# outputs a data frame: { case, time, attribute/value } +generate_activity_animation_attribute <- function(eventlog, value, default) { + attribute <- rlang::sym("value") + if (is.null(value)) { + # use fixed default value + eventlog %>% + as.data.frame() %>% + group_by(!!activity_id_(eventlog)) %>% + summarise(time = min(!!timestamp_(eventlog))) %>% + mutate(!!attribute := default) %>% + rename(act = !!activity_id_(eventlog)) + } else if (is.data.frame(value)) { + # check data present + stopifnot(c("act", "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)) %>% + arrange(!!case_id_(eventlog), !!timestamp_(eventlog)) %>% + select(act = !!activity_id_(eventlog), + time = !!timestamp_(eventlog), + !!attribute) + } else { + # set to a fixed value + eventlog %>% + as.data.frame() %>% + mutate(!!attribute := value) %>% + select(act = !!activity_id_(eventlog), + time = !!timestamp_(eventlog), + !!attribute) + } +} + +transform_activity_time <- function(data, mode, a_factor, timeline_start, timeline_end) { + + .order <- time <- case <- log_start <- case_start <- value <- act <- NULL + + data <- data %>% + group_by(act) %>% + filter(row_number() == 1 | lag(value) != value) # only keep changes in value + + if (mode == "absolute") { + data <- mutate(data, time = as.numeric(time - timeline_start, units = "secs")) + } else { + # unchanged but will be scaled + data <- mutate(data, time = as.numeric(time, units = "secs")) + } + + data %>% + mutate(time = time / a_factor) %>% + arrange(act, time) %>% + select(act, time, value) +} + + +# Utility functions +# https://github.com/gertjanssenswillen/processmapR/blob/master/R/utils.R +case_id_ <- function(eventlog) rlang::sym(bupaR::case_id(eventlog)) +timestamp_ <- function(eventlog) rlang::sym(bupaR::timestamp(eventlog)) +activity_id_ <- function(eventlog) rlang::sym(bupaR::activity_id(eventlog)) +activity_instance_id_ <- function(eventlog) rlang::sym(bupaR::activity_instance_id(eventlog)) diff --git a/inst/htmlwidgets/lib/modules/animation_activities.js b/inst/htmlwidgets/lib/modules/animation_activities.js new file mode 100644 index 0000000..d5e29d2 --- /dev/null +++ b/inst/htmlwidgets/lib/modules/animation_activities.js @@ -0,0 +1,207 @@ +/* +processanimateR +Copyright (c) 2019 Felix Mannhardt +Licensed under MIT license +*/ +function PAActivities(el, data, scales) { + + var colorScale = scales.actColorScale; + var linecolorScale = scales.actLinecolorScale; + var opacityScale = scales.actOpacityScale; + + var animateTextLoop = null; + + function safeNumber(x) { + return (parseFloat(x) || 0).toFixed(6); + } + + function generateActivityId(id) { + return el.id+"-edge" + id + "-path"; + } + + function isSingle(attr) { + return attr.length === 1; + } + + function isNullValue(attr) { + return attr.length === 1 && attr[0].value === null; + } + + function standardize_color(str){ + var ctx = document.createElement('canvas').getContext('2d'); + ctx.fillStyle = str; + return ctx.fillStyle; + } + + // Credits to: https://stackoverflow.com/a/5624139 + function hexToRgb(hex) { + // Expand shorthand form (e.g. "03F") to full form (e.g. "0033FF") + var shorthandRegex = /^#?([a-f\d])([a-f\d])([a-f\d])$/i; + hex = hex.replace(shorthandRegex, function(m, r, g, b) { + return r + r + g + g + b + b; + }); + + var result = /^#?([a-f\d]{2})([a-f\d]{2})([a-f\d]{2})$/i.exec(hex); + return result ? [ + parseInt(result[1], 16), + parseInt(result[2], 16), + parseInt(result[3], 16) + ] : null; + } + + // Credits to: https://stackoverflow.com/a/51034288 + function calcTextFill(color) { + var rgb = hexToRgb(standardize_color(color)); + var lrgb = []; + rgb.forEach(function(c) { + c = c / 255.0; + if (c <= 0.03928) { + c = c / 12.92; + } else { + c = Math.pow((c + 0.055) / 1.055, 2.4); + } + lrgb.push(c); + }); + var lum = 0.2126 * lrgb[0] + 0.7152 * lrgb[1] + 0.0722 * lrgb[2]; + return (lum > 0.179) ? '#000000' : '#ffffff'; + } + + this.insertActivityAnimation = function(svg) { + + if (animateTextLoop) { + animateTextLoop.forEach(function(animateLoop) { + window.cancelAnimationFrame(animateLoop); + }) + } + + var nodeElements = d3.select(svg) + .selectAll(".node") + .filter(function() { + return this.id !== "node"+data.start_activity && this.id !== "node"+data.end_activity; + }); + + var colors = HTMLWidgets.dataframeToD3(data.act_colors); + var linecolors = HTMLWidgets.dataframeToD3(data.act_linecolors); + var opacities = HTMLWidgets.dataframeToD3(data.act_opacities); + var labels = HTMLWidgets.dataframeToD3(data.act_labels); + + nodeElements.each(function(d, i) { + + var act_group_id = d3.select(this).attr('id'); + var act_path = d3.select(this).selectAll("path") + var text_node = d3.select(this).selectAll("text") + + var sameActivity = function (x) { + var actIdx = data.activities.act.indexOf(x.act) + var actNode = "node" + data.activities.id[actIdx]; + return(actNode == act_group_id); + + } + + var customAttrs = { + colors: colors.filter(sameActivity), + linecolors: linecolors.filter(sameActivity), + opacities: opacities.filter(sameActivity), + labels: labels.filter(sameActivity) + }; + + if (!isNullValue(customAttrs.colors)) { + if (isSingle(customAttrs.colors)) { + // Improve the rendering performance by avoiding animations if not necessary + act_path.attr("fill", colorScale(customAttrs.colors[0].value)); + text_node.attr("fill", calcTextFill(colorScale(customAttrs.colors[0].value))); + } else { + customAttrs.colors.forEach(function(d){ + act_path.append('set') + .attr("attributeName", "fill") + .attr("to", colorScale(d.value) ) + .attr("begin", safeNumber(d.time) + "s" ) + .attr("fill", "freeze"); + text_node.append('set') + .attr("attributeName", "fill") + .attr("to", calcTextFill(colorScale(d.value))) + .attr("begin", safeNumber(d.time) + "s" ) + .attr("fill", "freeze"); + }); + } + } + + if (isSingle(customAttrs.linecolors)) { + if (!isNullValue(customAttrs.linecolors)) { + act_path.attr("stroke", linecolorScale(customAttrs.linecolors[0].value)); + } + } else { + customAttrs.linecolors.forEach(function(d){ + act_path.append('set') + .attr("attributeName", "stroke") + .attr("to", linecolorScale(d.value) ) + .attr("begin", safeNumber(d.time) + "s" ) + .attr("fill", "freeze"); + }); + } + + if (isSingle(customAttrs.opacities)) { + if (!isNullValue(customAttrs.opacities)) { + act_path.attr("fill-opacity", opacityScale(customAttrs.opacities[0].value)); + } + } else { + customAttrs.opacities.forEach(function(d){ + act_path.append('set') + .attr("attributeName", "fill-opacity") + .attr("to", opacityScale(d.value) ) + .attr("begin", safeNumber(d.time) + "s" ) + .attr("fill", "freeze"); + }); + } + + // User defined attributes + if (data.act_attributes) { + act_path.attrs(data.act_attributes); + } + + // Text + + if (!isNullValue(customAttrs.labels)) { + var textEl = d3.select(this).select("a > text:nth-child(4)"); + textEl.text(customAttrs.labels[0].value); + if (!isSingle(customAttrs.labels)) { + // Single text does not make sense + if (!animateTextLoop) { + animateTextLoop = new Array(nodeElements.length); + } + + animateText(svg, data, i, textEl, customAttrs.labels); + } + } + + // Text + function animateText(svg, data, actIdx, textEl, textAttr) { + var lastTime = 0; + var throttleDelta = 1000 / 18; + (function(timestamp){ + if (timestamp - lastTime > throttleDelta) { + var time = svg.getCurrentTime(); + if (time > 0 && time <= data.duration && !svg.animationsPaused()) { + + var textEntry = textAttr.find(function(d) { + return d.time >= time; + }) + + if (textEntry) { + textEl.text(textEntry.value); + } + + } + lastTime = timestamp; + } + animateTextLoop[actIdx] = window.requestAnimationFrame(arguments.callee); + })(); + } + + + }); + + + }; + +} diff --git a/inst/htmlwidgets/lib/modules/animation_playback_control.js b/inst/htmlwidgets/lib/modules/animation_playback_control.js index 9ebfae0..c22efea 100644 --- a/inst/htmlwidgets/lib/modules/animation_playback_control.js +++ b/inst/htmlwidgets/lib/modules/animation_playback_control.js @@ -1,5 +1,5 @@ /* -processanimateR 1.0.3 +processanimateR Copyright (c) 2019 Felix Mannhardt Licensed under MIT license */ diff --git a/inst/htmlwidgets/lib/modules/animation_renderer_graphviz.js b/inst/htmlwidgets/lib/modules/animation_renderer_graphviz.js index f6fbbb8..4d4def5 100644 --- a/inst/htmlwidgets/lib/modules/animation_renderer_graphviz.js +++ b/inst/htmlwidgets/lib/modules/animation_renderer_graphviz.js @@ -1,5 +1,5 @@ /* -processanimateR 1.0.3 +processanimateR Copyright (c) 2019 Felix Mannhardt Licensed under MIT license */ diff --git a/inst/htmlwidgets/lib/modules/animation_renderer_leaflet.js b/inst/htmlwidgets/lib/modules/animation_renderer_leaflet.js index b3cf209..fe45fa6 100644 --- a/inst/htmlwidgets/lib/modules/animation_renderer_leaflet.js +++ b/inst/htmlwidgets/lib/modules/animation_renderer_leaflet.js @@ -1,5 +1,5 @@ /* -processanimateR 1.0.3 +processanimateR Copyright (c) 2019 Felix Mannhardt Licensed under MIT license */ diff --git a/inst/htmlwidgets/lib/modules/animation_scales.js b/inst/htmlwidgets/lib/modules/animation_scales.js index d51b7b9..c1277b0 100644 --- a/inst/htmlwidgets/lib/modules/animation_scales.js +++ b/inst/htmlwidgets/lib/modules/animation_scales.js @@ -1,5 +1,5 @@ /* -processanimateR 1.0.3 +processanimateR Copyright (c) 2019 Felix Mannhardt Licensed under MIT license */ @@ -8,8 +8,11 @@ function PAScales(el) { var legendSvg = null; this.colorScale = null; + this.actColorScale = null; + this.actLinecolorScale = null; this.sizeScale = null; this.opacityScale = null; + this.actOpacityScale = null; this.imageScale = null; this.update = function(data) { @@ -31,6 +34,7 @@ function PAScales(el) { data.images.value = data.images.value.map(function(x) { return moment(x).toDate(); }); } + this.colorScale = buildScale(data.colors_scale, data.colors, "#FFFFFF"); @@ -47,6 +51,30 @@ function PAScales(el) { data.images, ""); + if (data.act_colors_scale.scale === "time") { + data.act_colors.value = data.act_colors.value.map(function(x) { return moment(x).toDate(); }); + } + + if (data.act_linecolors_scale.scale === "time") { + data.act_linecolors.value = data.act_linecolors.value.map(function(x) { return moment(x).toDate(); }); + } + + if (data.act_opacities_scale.scale === "time") { + data.act_opacities.value = data.act_opacities.value.map(function(x) { return moment(x).toDate(); }); + } + + this.actColorScale = buildScale(data.act_colors_scale, + data.act_colors, + "#FFFFFF"); + + this.actLinecolorScale = buildScale(data.act_linecolors_scale, + data.act_linecolors, + "#FFFFFF"); + + this.actOpacityScale = buildScale(data.act_opacities_scale, + data.act_opacities, + 0.9); + }; this.renderLegend = function(data, svg, width, height) { @@ -58,6 +86,7 @@ function PAScales(el) { if (data.legend && data.tokens.case !== undefined && !(data.colors_scale === "time" || + data.act_colors_scale === "time" || data.sizes_scale === "time")) { if (!legendSvg) { @@ -81,6 +110,9 @@ function PAScales(el) { case "color": legendGroup.call(d3.legendColor().scale(this.colorScale).shape("circle").shapeRadius(6)); break; + case "act_color": + legendGroup.call(d3.legendColor().scale(this.actColorScale).shape("circle").shapeRadius(6)); + break; case "size": legendGroup.call(d3.legendSize().scale(this.sizeScale).shape("circle")); break; diff --git a/inst/htmlwidgets/lib/modules/animation_tokens.js b/inst/htmlwidgets/lib/modules/animation_tokens.js index 9a2036c..aba62b0 100644 --- a/inst/htmlwidgets/lib/modules/animation_tokens.js +++ b/inst/htmlwidgets/lib/modules/animation_tokens.js @@ -1,5 +1,5 @@ /* -processanimateR 1.0.3 +processanimateR Copyright (c) 2019 Felix Mannhardt Licensed under MIT license */ @@ -46,8 +46,7 @@ function PATokens(el, data, scales) { begin: function(d) { return safeNumber(d.token_start) + "s"; }, dur: function(d) { return safeNumber(d.token_duration) + "s"; }, fill: "freeze", - rotate: "auto" - }) + rotate: "auto" }) .append("mpath") .attr("href", function(d) { return "#"+generateEdgeId(d.edge_id); }); diff --git a/inst/htmlwidgets/processanimateR.js b/inst/htmlwidgets/processanimateR.js index 0ee92e4..ee57e97 100644 --- a/inst/htmlwidgets/processanimateR.js +++ b/inst/htmlwidgets/processanimateR.js @@ -1,5 +1,5 @@ /* -processanimateR 1.0.3 +processanimateR Copyright (c) 2019 Felix Mannhardt Licensed under MIT license */ @@ -13,6 +13,7 @@ HTMLWidgets.widget({ var control = new PAPlaybackControl(el); var scales = new PAScales(el); var tokens = null; + var activities = null; var renderer = null; return { @@ -36,6 +37,7 @@ HTMLWidgets.widget({ scales.update(data); tokens = new PATokens(el, data, scales); + activities = new PAActivities(el, data, scales); // Render process map if (data.processmap_renderer === "map") { @@ -50,6 +52,7 @@ HTMLWidgets.widget({ if (data.tokens.case !== undefined) { // Generate tokens and animations tokenGroup = tokens.insertTokens(svg); + activities.insertActivityAnimation(svg); } tokens.attachEventListeners(svg, tokenGroup); diff --git a/inst/htmlwidgets/processanimateR.yaml b/inst/htmlwidgets/processanimateR.yaml index c62e1c7..790117b 100644 --- a/inst/htmlwidgets/processanimateR.yaml +++ b/inst/htmlwidgets/processanimateR.yaml @@ -3,9 +3,11 @@ dependencies: version: 1.0.3 src: "htmlwidgets/lib/modules" script: + - animation_activities.js - animation_playback_control.js - animation_scales.js - animation_tokens.js + - animation_activities.js - animation_renderer_graphviz.js - animation_renderer_leaflet.js all_files: FALSE diff --git a/man/activity_aes.Rd b/man/activity_aes.Rd new file mode 100644 index 0000000..2c57bdc --- /dev/null +++ b/man/activity_aes.Rd @@ -0,0 +1,51 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/aesthetics.R +\name{activity_aes} +\alias{activity_aes} +\title{Activity aesthetics mapping} +\usage{ +activity_aes( + color = activity_scale(), + linecolor = activity_scale(), + opacity = activity_scale(), + label = activity_scale(), + attributes = list() +) +} +\arguments{ +\item{color}{The scale used for the activity color,} + +\item{linecolor}{The scale used for the activity color,} + +\item{opacity}{The scale used for the activity opacity.} + +\item{label}{The scale used for the additional activity label. Usually an `identity` scale makes sense here.} + +\item{attributes}{A list of additional (fixed - non changing) SVG attributes to be added to each activity.} +} +\value{ +An aesthetics mapping for `animate_process`. +} +\description{ +Activity aesthetics mapping +} +\examples{ +data(example_log) +library(eventdataR) +animate_process(patients, + mode = "absolute", + legend = "act_color", + duration = 300, + mapping_activity = + activity_aes(color = activity_scale("employee", scale = "ordinal", + range = c("red", "green", "blue", "yellow")), + linecolor = activity_scale("time", scale = "time", + range = c("white", "black")), + opacity = activity_scale("time", scale = "time", range = c(0.3, 1.0)), + label = activity_scale("employee", scale = "identity"))) + + +} +\seealso{ +\code{\link{animate_process}}, \code{\link{activity_scale}} +} diff --git a/man/activity_scale.Rd b/man/activity_scale.Rd new file mode 100644 index 0000000..df17735 --- /dev/null +++ b/man/activity_scale.Rd @@ -0,0 +1,39 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/scale.R +\name{activity_scale} +\alias{activity_scale} +\title{Activity scale mapping values to aesthetics} +\usage{ +activity_scale( + attribute = NULL, + scale = c("identity", "linear", "sqrt", "log", "quantize", "ordinal", "time"), + domain = NULL, + range = NULL +) +} +\arguments{ +\item{attribute}{This may be (1) the name of the event attribute to be used as values, +(2) a data frame with three columns (act, time, value) in which the values in the act column are matching the activity identifier of the supplied event log, or +(3) a constant value that does not change over time.} + +\item{scale}{Which D3 scale function to be used out of `identity`, `linear`, `sqrt`, `log`, `quantize`, `ordinal`, or `time`.} + +\item{domain}{The domain of the D3 scale function. Can be left NULL in which case it will be automatically determined based on the values.} + +\item{range}{The range of the D3 scale function. Should be a vector of two or more numerical values.} +} +\value{ +A scale to be used with `mapping_activity` +} +\description{ +Creates a `list` of parameters suitable to be used as activity scale in (\code{\link{activity_aes}}) for mapping values to certain aesthetics of the activity in a process map animation. + Refer to the d3-scale documentation (https://github.com/d3/d3-scale) for more information about how to set `domain` and `range` properly. +} +\examples{ +data(example_log) + + +} +\seealso{ +\code{\link{animate_process}}, \code{\link{activity_aes}} +} diff --git a/man/animate_process.Rd b/man/animate_process.Rd index e61fbdc..cffcd66 100644 --- a/man/animate_process.Rd +++ b/man/animate_process.Rd @@ -19,6 +19,7 @@ animate_process( repeat_delay = 0.5, epsilon_time = duration/1000, mapping = token_aes(), + mapping_activity = activity_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) {", "}"), @@ -66,6 +67,9 @@ Adding jitter can help to disambiguate tokens drawn on top of each other.} \item{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.} +\item{mapping_activity}{A list of aesthetic mappings from event log attributes to certain visual parameters of the activities +Use \code{\link{activity_aes}} to create a suitable mapping list.} + \item{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'.} diff --git a/man/token_aes.Rd b/man/token_aes.Rd index ce684f1..e28488c 100644 --- a/man/token_aes.Rd +++ b/man/token_aes.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/token_aes.R +% Please edit documentation in R/aesthetics.R \name{token_aes} \alias{token_aes} \title{Tokens aesthetics mapping} diff --git a/man/token_scale.Rd b/man/token_scale.Rd index 3b75baf..1298de7 100644 --- a/man/token_scale.Rd +++ b/man/token_scale.Rd @@ -23,7 +23,7 @@ token_scale( \item{range}{The range of the D3 scale function. Should be a vector of two or more numerical values.} } \value{ -A scale to be used with `token_mapping` +A scale to be used with `mapping` } \description{ Creates a `list` of parameters suitable to be used as token scale in (\code{\link{token_aes}}) for mapping values to certain aesthetics of the tokens in a process map animation. diff --git a/vignettes/use-external-data-to-change-activites.Rmd b/vignettes/use-external-data-to-change-activites.Rmd new file mode 100644 index 0000000..9373466 --- /dev/null +++ b/vignettes/use-external-data-to-change-activites.Rmd @@ -0,0 +1,58 @@ +--- +title: "Use external data (process context) to change activity aesthetics" +author: "Felix Mannhardt" +date: "`r Sys.Date()`" +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{Use external data (process context) to change activity aesthetics} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + +```{r setup, include = FALSE} +knitr::opts_chunk$set( + collapse = TRUE, + comment = "#>" +) +``` + +It is possible to use a secondary data frame to determine the aesthetics of *activities* irregardless of the times at which activities actually occurred. This can be useful to show system level behavior that happens across several cases on the activities. For example, the number of currently active cases, or an average of a measurement over a certain time period. + +For example, here the 30 minute average of the latest lactic acid measurements from cases in which a certain activity is performed in the `sepsis` event log is used: +```{r echo = TRUE, message = FALSE} +library(processanimateR) +library(dplyr) +library(bupaR) + +# Extract only the lacticacid measurements +lactic <- sepsis %>% + mutate(lacticacid = as.numeric(lacticacid)) %>% + arrange(case_id, timestamp) %>% + as.data.frame() %>% + bupaR::fill(lacticacid, .direction = "up") %>% + mutate("act" = activity, + value = lacticacid) %>% + as.data.frame() %>% + mutate(time = lubridate::floor_date(timestamp, "30 mins")) %>% + group_by(act, time) %>% + summarise(value = mean(value), .groups = "drop") %>% + select(act, + time, + value) # format needs to be 'act,time,value' + +lacticLabel <- lactic %>% + mutate(value = paste0(value, " mmol/L")) + +# Remove the measurement events from the sepsis log +sepsisBase <- sepsis %>% + filter_activity(c("LacticAcid", "CRP", "Leucocytes", "Return ER", + "IV Liquid", "IV Antibiotics"), reverse = T) %>% + filter_trace_frequency(percentage = 0.95) + +# Animate activity aesthetics with the secondary data frame `lactic` +animate_process(sepsisBase, + mode = "absolute", + duration = 300, + mapping_activity = activity_aes(label = activity_scale(lacticLabel, scale = "identity"), + color = activity_scale(lactic, scale = "linear", range = c("#fff5eb","#7f2704")))) +``` diff --git a/vignettes/use-with-shiny.Rmd b/vignettes/use-with-shiny.Rmd index d859de6..dd01854 100644 --- a/vignettes/use-with-shiny.Rmd +++ b/vignettes/use-with-shiny.Rmd @@ -1,5 +1,5 @@ --- -title: "Use processanimateR and Shiny" +title: "Use processanimateR in Shiny" author: "Felix Mannhardt" date: "`r Sys.Date()`" output: rmarkdown::html_vignette