-
Notifications
You must be signed in to change notification settings - Fork 6
/
performance.R
146 lines (130 loc) · 5.33 KB
/
performance.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
#' @title Performance map profile
#' @description Function to create a performance map profile to be used as the type of a process map. It results in a process map describing process time.
#' @param FUN A summary function to be called on the process time of a specific activity, e.g. mean, median, min, max
#' @param units The time unit in which processing time should be presented (mins, hours, days, weeks, months, quarters, semesters, years. A month is defined as 30 days. A quarter is 13 weeks. A semester is 26 weeks and a year is 365 days
#' @param flow_time The time to depict on the flows: the inter start time is the time between the start timestamp of consecutive activity instances,
#' the idle time is the time between the end and start time of consecutive activity instances.
#' @param color_scale Name of color scale to be used for nodes. Defaults to Reds. See `Rcolorbrewer::brewer.pal.info()` for all options.
#' @param color_edges The color used for edges. Defaults to red4.
#' @param ... Additional arguments too FUN
#' @export performance
performance <- function(FUN = mean,
units = c("mins","secs", "hours","days","weeks", "months", "quarters", "semesters","years"),
flow_time = c("idle_time","inter_start_time"),
color_scale = "Reds",
color_edges = "red4",
...) {
flow_time <- match.arg(flow_time)
units <- match.arg(units)
attr(FUN, "flow_time") <- flow_time
attr(FUN, "perspective") <- "performance"
attr(FUN, "units_label") <- units
attr(FUN, "arguments") <- list(...)
if(units %in% c("mins","hours","days","weeks", "secs")) {
attr(FUN, "units") <- units
attr(FUN, "scale_time") <- 1
} else if (units == "months") {
attr(FUN, "units") <- "days"
attr(FUN, "scale_time") <- 1/30
} else if (units == "semesters") {
attr(FUN, "units") <- "days"
attr(FUN, "scale_time") <- 1/(26*7)
}
else if (units == "years") {
attr(FUN, "units") <- "days"
attr(FUN, "scale_time") <- 1/(365)
} else if(units == "quarters") {
attr(FUN, "units") <- "days"
attr(FUN, "scale_time") <- 1/(13*7)
}
attr(FUN, "color") <- color_scale
attr(FUN, "color_edges") <- color_edges
attr(FUN, "create_nodes") <- function(precedence, type, extra_data) {
from_id <- NULL
to_id <- NULL
label <- NULL
tooltip <- NULL
next_act <- NULL
end_time <- NULL
start_time <- NULL
duration <- NULL
antecedent <- NULL
time <- NULL
value <- NULL
ACTIVITY_CLASSIFIER_ <- NULL
label_numeric <- NULL
consequent <- NULL
precedence %>%
mutate(duration = as.double(end_time-start_time, units = attr(type, "units"))*attr(type, "scale_time")) %>%
group_by(ACTIVITY_CLASSIFIER_, from_id) %>%
summarize(label = do.call(function(...) type(duration, na.rm = T,...), attr(type, "arguments"))) %>%
na.omit() %>%
ungroup() %>%
mutate(color_level = label,
value = label,
shape = if_end(ACTIVITY_CLASSIFIER_,"circle","rectangle"),
fontcolor = if_end(ACTIVITY_CLASSIFIER_, if_start(ACTIVITY_CLASSIFIER_, "chartreuse4","brown4"), ifelse(label <= (min(label) + (5/8)*diff(range(label))), "black","white")),
color = if_end(ACTIVITY_CLASSIFIER_, if_start(ACTIVITY_CLASSIFIER_, "chartreuse4","brown4"),"grey"),
tooltip = paste0(ACTIVITY_CLASSIFIER_, "\n", round(label, 2), " ",attr(type, "units_label")),
label = if_end(ACTIVITY_CLASSIFIER_, recode(ACTIVITY_CLASSIFIER_, ARTIFICIAL_START = "Start",ARTIFICIAL_END = "End"),
tooltip))
}
attr(FUN, "create_edges") <- function(precedence, type, extra_data) {
flow_time <- attr(type, "flow_time")
from_id <- NULL
to_id <- NULL
label <- NULL
tooltip <- NULL
next_act <- NULL
end_time <- NULL
start_time <- NULL
duration <- NULL
antecedent <- NULL
time <- NULL
value <- NULL
ACTIVITY_CLASSIFIER_ <- NULL
label_numeric <- NULL
consequent <- NULL
precedence %>%
ungroup() %>%
mutate(time = case_when(flow_time == "inter_start_time" ~ as.double(next_start_time - start_time, units = attr(type, "units"))*attr(type, "scale_time"),
flow_time == "idle_time" ~ as.double(next_start_time - end_time, units = attr(type, "units"))*attr(type, "scale_time"))) %>%
group_by(ACTIVITY_CLASSIFIER_, next_act, from_id, to_id) %>%
summarize(value = do.call(function(...) type(time, na.rm = T,...), attr(type, "arguments")),
n = as.double(n())) %>%
mutate(label_numeric = value) %>%
mutate( label = paste0(round(value,2), " ", attr(type, "units_label"))) %>%
na.omit() %>%
ungroup() %>%
mutate(penwidth = rescale(value, to = c(1,5))) %>%
mutate(label = if_end(ACTIVITY_CLASSIFIER_, " ", if_end(next_act, " ", label))) %>%
select(-value)
}
attr(FUN, "transform_for_matrix") <- function(edges, type, extra_data) {
from_id <- NULL
to_id <- NULL
label <- NULL
end_time <- NULL
start_time <- NULL
duration <- NULL
time <- NULL
tooltip <- NULL
penwidth <- NULL
antecedent <- NULL
next_act <- NULL
value <- NULL
ACTIVITY_CLASSIFIER_ <- NULL
label_numeric <- NULL
consequent <- NULL
n_consequents <- length(unique(edges$next_act))
edges %>%
rename(antecedent = ACTIVITY_CLASSIFIER_,
consequent = next_act) %>%
mutate(antecedent = fct_relevel(antecedent, "Start"),
consequent = fct_relevel(consequent, "End", after = n_consequents - 1)) %>%
select(-from_id, -to_id, -penwidth, -label) %>%
rename(flow_time = label_numeric) -> edges
return(edges)
}
return(FUN)
}