Initial version

Author: fmannhardt

.Rbuildignore

@@ -0,0 +1,5 @@
+^docs$
+^_pkgdown\.yml$
+^LICENSE\.md$
+^.*\.Rproj$
+^\.Rproj\.user$

.gitignore

@@ -0,0 +1,3 @@
+.Rhistory
+.RData
+.Rproj.user

LICENSE.md

@@ -0,0 +1,32 @@
+# Generated by roxygen2: do not edit by hand
+
+S3method(py_str,pm4py.objects.log.log.Trace)
+S3method(py_str,pm4py.objects.log.log.TraceLog)
+S3method(py_to_r,pm4py.objects.log.log.EventLog)
+S3method(py_to_r,pm4py.objects.log.log.TraceLog)
+S3method(py_to_r,pm4py.objects.petri.petrinet.Marking)
+S3method(py_to_r,pm4py.objects.petri.petrinet.PetriNet)
+S3method(r_to_py,eventlog)
+S3method(r_to_py,petrinet)
+export(conformance_alignment)
+export(discovery_alpha)
+export(discovery_inductive)
+export(install_pm4py)
+export(param_activity_key)
+export(param_attribute_key)
+export(param_caseid_key)
+export(param_resource_key)
+export(param_timestamp_key)
+export(petrinet_synchronous_product)
+export(pm4py)
+export(variant_alpha_classic)
+export(variant_inductive_only_dfg)
+export(variant_state_equation_a_star)
+export(version)
+import(dplyr)
+import(reticulate)
+importFrom(magrittr,"%>%")
+importFrom(reticulate,iterate)
+importFrom(reticulate,py_str)
+importFrom(reticulate,py_to_r)
+importFrom(reticulate,r_to_py)

NAMESPACE

@@ -0,0 +1,81 @@
+#' Alignment between an Event Log and a Petri net
+#'
+#' @param eventlog A bupaR or PM4PY event log.
+#' @param petrinet A bupaR or PM4PY Petri net.
+#' @param initial_marking A R vector with the place identifiers of the initial marking or a PM4PY marking.
+#' By default the initial marking of the bupaR Petri net will be used if available.
+#' @param final_marking A R vector with the place identifiers of the final marking or a PM4PY marking.
+#' @param parameters PM4PY alignment parameter.
+#' By default the `activity_key` from the bupaR event log is specified using \link{param_activity_key}.
+#' @param variant The alignment variant to be used.
+#' @param convert `TRUE` to automatically convert Python objects to their R equivalent. If you pass `FALSE` you can do manual conversion using the \link[reticulate]{r-py-conversion} function.
+#'
+#' @return A `data.frame` describing the alignment in terms of log and model moves.
+#' @export
+#'
+#' @examples
+#' \dontrun{
+#' net <- discovery_inductive(patients)
+#'
+#' a <- conformance_alignment(patients,
+#'                            net$petrinet,
+#'                            net$initial_marking,
+#'                            net$final_marking)
+#' }
+#'
+#' @import dplyr
+#' @importFrom magrittr "%>%"
+conformance_alignment <- function(eventlog,
+                                  petrinet,
+                                  initial_marking,
+                                  final_marking,
+                                  parameters = param_activity_key(bupaR::activity_id(eventlog)),
+                                  variant = variant_state_equation_a_star(),
+                                  convert = TRUE) {
+
+  pm4py_alignments <- import("pm4py.algo.conformance.alignments.factory", convert = convert)
+  if (is.null(initial_marking) && inherits(petrinet, "petrinet")) {
+    initial_marking <- petrinet$marking
+  }
+
+  py_pn <- as_py_value(petrinet)
+  py_log <- as_py_value(eventlog)
+
+  alignment <- pm4py_alignments$apply(obj = py_log,
+                                      petri_net = py_pn,
+                                      initial_marking = as_pm4py_marking(initial_marking, py_pn),
+                                      final_marking = as_pm4py_marking(final_marking, py_pn),
+                                      parameters = parameters,
+                                      version = variant)
+
+  if (convert) {
+
+    case_ids <- eventlog %>% as.data.frame() %>%
+      distinct(!!as.symbol(bupaR::case_id(eventlog))) %>%
+      pull()
+
+    purrr::map2_dfr(alignment, case_ids, function(trace, case_id) {
+
+      align_mat <- t(sapply(trace$alignment, c)) # convert nested lists to matrix
+      align_mat[vapply(align_mat, is.null, TRUE)] <- NA_character_
+      align_lst <- apply(align_mat, 2, unlist) # remove wrapper lists from elements
+
+      trace_df <- data.frame(align_lst, stringsAsFactors = FALSE)
+      names(trace_df) <- c("logmove", "modelmove")
+
+      cbind(case_id, trace_df, trace[-1],  # add meta information by duplicating it since we don't have a trace object
+            stringsAsFactors = FALSE)
+    })
+  } else {
+    alignment
+  }
+}
+
+#'A* search using the state equation as heuristic
+#'
+#' @export
+variant_state_equation_a_star <- function() {
+  pm4py$algo$conformance$alignments$factory$VERSION_STATE_EQUATION_A_STAR
+}
+
+

R/alignments.R

@@ -0,0 +1,126 @@
+#' @export
+#' @importFrom reticulate r_to_py
+r_to_py.eventlog <- function(x, convert = FALSE) {
+
+  pm4py_log <- import("pm4py.objects.log", convert = convert)
+  conversion_factory <- import("pm4py.objects.conversion.log.factory", convert = convert)
+
+  p_df <- r_to_py(as.data.frame(x), convert = convert)
+  p_eventlog <- pm4py_log$log$EventLog(p_df$to_dict('records'))
+
+  case_glue <- py_to_r(pm4py_log$util$general$PARAMETER_KEY_CASE_GLUE)
+  conversion_factory$apply(p_eventlog,
+                           parameters = py_dict(case_glue, bupaR::case_id(x)),
+                           version = conversion_factory$TO_TRACE_LOG)
+}
+
+#' @export
+#' @importFrom reticulate py_to_r
+py_to_r.pm4py.objects.log.log.EventLog <- function(x) {
+  pm4py$objects$log$exporter$csv$versions$pandas_csv_exp$get_dataframe_from_log(x)
+}
+
+#' @export
+#' @importFrom reticulate py_to_r
+py_to_r.pm4py.objects.log.log.TraceLog <- function(x) {
+  pm4py$objects$log$exporter$csv$versions$pandas_csv_exp$get_dataframe_from_log(x)
+}
+
+#' @importFrom reticulate py_str
+#' @export
+py_str.pm4py.objects.log.log.TraceLog <- function(object, ...) {
+  pm4py_str_sequence("TraceLog", object, ...)
+}
+
+#' @importFrom reticulate py_str
+#' @export
+py_str.pm4py.objects.log.log.Trace <- function(object, ...) {
+  pm4py_str_sequence("Trace", object, ...)
+}
+
+pm4py_str_sequence <- function(name, x, ...) {
+  len <- py_len(x)
+  cat(name, " (", len, " items)", "\n",
+      paste0(lapply(1:(min(10,len)), function(i) py_str(x[i])), collapse = ",\n"), sep = "")
+  if (len > 10) {
+    cat("\n... with ", len-10," more items")
+  }
+}
+
+#' @export
+#' @importFrom reticulate r_to_py
+r_to_py.petrinet <- function(x, convert = FALSE) {
+
+  pm4py_petrinet <- import("pm4py.objects.petri.petrinet", convert = convert)
+  py_builtins <- import_builtins(convert = convert)
+
+  if ("label" %in% names(x$transitions)) {
+    t_labels <- x$transitions$label
+  } else {
+    t_labels <- rep(NA, nrow(x$transitions))
+  }
+
+  t_list <- Map(function(name, label) {
+    if (is.na(label)) {
+      label <- NULL
+    }
+    pm4py_petrinet$PetriNet$Transition(name, label)
+  }, x$transitions$id, t_labels)
+
+  p_list <- Map(function(p) pm4py_petrinet$PetriNet$Place(p), x$places$id)
+
+  a_list <- Map(function(from, to) {
+    if (from %in% names(t_list)) {
+      source <- t_list[[from]]
+      target <- p_list[[to]]
+    } else {
+      source <- p_list[[from]]
+      target <- t_list[[to]]
+    }
+
+    a <- pm4py_petrinet$PetriNet$Arc(source, target)
+
+    source$out_arcs$add(a)
+    target$in_arcs$add(a)
+
+    return(a)
+
+  }, x$flows$from, x$flows$to)
+
+  pm4py_petrinet$PetriNet(
+    places = unname(unlist(p_list)),
+    transitions = unname(unlist(t_list)),
+    arcs = py_builtins$set(unname(unlist(a_list)))
+  )
+}
+
+#' @export
+#' @importFrom reticulate iterate
+#' @importFrom reticulate py_to_r
+py_to_r.pm4py.objects.petri.petrinet.PetriNet <- function(x) {
+
+  places <- unlist(iterate(x$places, function(p) ensure_str(p$name)))
+  transitions <- unlist(iterate(x$transitions, function(t) ensure_str(t$name)))
+
+  arcs_from <- unlist(iterate(x$arcs, function(a) ensure_str(a$source$name)))
+  arcs_to <- unlist(iterate(x$arcs,function(a) ensure_str(a$target$name)))
+
+  flows <- data.frame(from = arcs_from, to = arcs_to,
+                      stringsAsFactors = F)
+
+  pn <- petrinetR::create_PN(places, transitions, flows,
+                             c()) # pm4py Petri net does not know about marking
+
+  # Make sure that labels are strings since PM4PY sometimes uses tuples or other objects
+  # Also, replace NULL by NA to avoid issues with R removing elements
+  pn$transitions$label <- iterate(x$transitions, function(t) ensure_str(t$label))
+
+  pn
+}
+
+#' @export
+#' @importFrom reticulate iterate
+#' @importFrom reticulate py_to_r
+py_to_r.pm4py.objects.petri.petrinet.Marking <- function(x) {
+  iterate(x$elements(), function(p) ensure_str(p$name))
+}

R/bridge.R

@@ -0,0 +1,74 @@
+#' Petri net discovery algorithms
+#'
+#' PM4PY discovery algorithms that discover a Petri net and its initial and final marking. Currently the Inductive Miner and the Alpha Miner are implemented.
+#'
+#' @param eventlog A bupaR event log.
+#' @param parameters A named list of PM4PY parameters, by default the `activity_key` from the bupaR event log is used. Use \link{param_activity_key} to specifiy a different key.
+#' @param variant The variant of the discovery algorithm to be used. For Inductive Miner currently only `variant_inductive_only_dfg` is supported.
+#' @param convert TRUE to automatically convert Python objects to their R equivalent. If you pass FALSE you can do manual conversion using the \link[reticulate]{r-py-conversion} function.
+#'
+#' @return A named list with elements `petrinet`, `initial_marking`, and `final_marking` or the original Python object.
+#'
+#' @examples
+#' \dontrun{
+#' data(patients)
+#' net <- discovery_inductive(patients)
+#'
+#' # Show details of the obtained bupaR Petri net
+#' print(net$petrinet)
+#'
+#' # initial marking is a character vector
+#' print(net$initial_marking)
+#'
+#' # final marking is a character vector
+#' print(net$final_marking)
+#'
+#' # Petri net can be used with other bupaR functions
+#' petrinetR::render_PN(net$petrinet)
+#'
+#' # Keep an unconverted PM4PY Petri net for use in other PM4PY functions
+#' py_net <- discovery_inductive(patients, convert = FALSE)
+#' }
+#'
+#' @name discovery
+NULL
+
+#' @rdname discovery
+#' @import reticulate
+#' @export
+discovery_inductive <- function(eventlog,
+                                parameters = param_activity_key(bupaR::activity_id(eventlog)),
+                                variant = variant_inductive_only_dfg(),
+                                convert = TRUE) {
+  pm4py_inductive <- import("pm4py.algo.discovery.inductive.factory", convert = convert)
+  model <- pm4py_inductive$apply(as_py_value(eventlog),
+                                 parameters = parameters,
+                                 variant = variant)
+  prepare_pn_with_markings(model, convert)
+}
+
+#' @rdname discovery
+#' @export
+variant_inductive_only_dfg <- function() {
+  pm4py$algo$discovery$inductive$factory$INDUCTIVE_ONLY_DFG
+}
+
+#' @rdname discovery
+#' @import reticulate
+#' @export
+discovery_alpha <- function(eventlog,
+                                parameters = param_activity_key(bupaR::activity_id(eventlog)),
+                                variant = variant_alpha_classic(),
+                                convert = TRUE) {
+  pm4py_alpha <- import("pm4py.algo.discovery.alpha.factory", convert = convert)
+  model <- pm4py_alpha$apply(as_py_value(eventlog),
+                             parameters = parameters,
+                             version = variant)
+  prepare_pn_with_markings(model, convert)
+}
+
+#' @rdname discovery
+#' @export
+variant_alpha_classic <- function() {
+  pm4py$algo$discovery$alpha$factory$ALPHA_VERSION_CLASSIC
+}

R/discovery.R

@@ -0,0 +1,18 @@
+#' Install pm4py library
+#'
+#' Installs the pm4py into a virtualenv or conda env.
+#'
+#' @param method Installation method. By default, "auto" automatically finds a method that will work in the local environment. Change the default to force a specific installation method. Note that the "virtualenv" method is not available on Windows.
+#' @param conda Path to conda executable (or "auto" to find conda using the PATH and other conventional install locations).
+#' @param ... Additional arguments passed to py_install().
+#'
+#' @export
+#'
+#' @examples
+#' \dontrun{
+#' install_pm4py()
+#' }
+#'
+install_pm4py <- function(method = "auto", conda = "auto", ...) {
+  reticulate::py_install("pm4py", method = method, conda = conda, pip = TRUE, ...)
+}

R/install.R

@@ -0,0 +1,23 @@
+#' @import reticulate
+NULL
+
+.onLoad <- function(libname, pkgname) {
+  # use superassignment to update global reference to pm4py
+  pm4py <<- import("pm4py", delay_load = TRUE)
+}
+
+#' Returns pm4py version used
+#'
+#' @return package_version S3 class
+#' @export
+#'
+#' @examples
+#' \dontrun{
+#' # Prints PM4PY version used
+#' version()
+#' }
+version <- function() {
+  ver <- pm4py$`__version__`
+  ver <- regmatches(ver, regexec("^([0-9\\.]+).*$", ver))[[1]][[2]]
+  package_version(ver)
+}

R/package.R

@@ -0,0 +1,58 @@
+#' PM4PY parameter keys
+#'
+#' Convenience methods to use PM4PY parameter keys.
+#'
+#' @param value The value to add to the list.
+#'
+#' @return a list with the parameter key/value pair
+#'
+#' @name parameters
+NULL
+
+#' @rdname parameters
+#' @export
+param_activity_key <- function(value) {
+  l <- list(value)
+  names(l) <- pm4py_parameters$activity_key
+  l
+}
+
+#' @rdname parameters
+#' @export
+param_attribute_key <- function(value) {
+  l <- list(value)
+  names(l) <- pm4py_parameters$attribute_key
+  l
+}
+
+#' @rdname parameters
+#' @export
+param_timestamp_key <- function(value) {
+  l <- list(value)
+  names(l) <- pm4py_parameters$timestamp_key
+  l
+}
+
+#' @rdname parameters
+#' @export
+param_caseid_key <- function(value) {
+  l <- list(value)
+  names(l) <- pm4py_parameters$caseid_key
+  l
+}
+
+#' @rdname parameters
+#' @export
+param_resource_key <- function(value) {
+  l <- list(value)
+  names(l) <- pm4py_parameters$resource_key
+  l
+}
+
+pm4py_parameters <- list(
+  activity_key = "pm4py:param:activity_key",
+  attribute_key = "pm4py:param:attribute_key",
+  timestamp_key = "pm4py:param:timestamp_key",
+  caseid_key = "case_id_glue",
+  resource_key = "pm4py:param:resource_key"
+)

R/parameters.R

@@ -0,0 +1,37 @@
+#' Constructs the synchronous product net of two given Petri nets.
+#'
+#' @param pn1 First Petri net
+#' @param im1 Initial marking of the first Petri net
+#' @param fm1 Final marking of the first Petri net
+#' @param pn2 Second Petri net
+#' @param im2 Initial marking of the second Petri net
+#' @param fm2 Final marking of the second Petri net
+#' @param skip Symbol to be used as skip
+#' @param convert `TRUE` to automatically convert Python objects to their R equivalent. If you pass `FALSE` you can do manual conversion using the \link[reticulate]{r-py-conversion} function.
+#'
+#' @import reticulate
+#' @export
+petrinet_synchronous_product <- function(pn1,
+                                         im1,
+                                         fm1,
+                                         pn2,
+                                         im2,
+                                         fm2,
+                                         skip = ">>",
+                                         convert = TRUE) {
+
+  pm4py_sync <- import("pm4py.objects.petri.synchronous_product", convert = convert)
+
+  pn1 <- as_py_value(pn1)
+  pn2 <- as_py_value(pn2)
+
+  sync_net <- pm4py_sync$construct(pn1,
+                                   as_pm4py_marking(im1, pn1),
+                                   as_pm4py_marking(fm1, pn1),
+                                   pn2,
+                                   as_pm4py_marking(im2, pn2),
+                                   as_pm4py_marking(fm2, pn2),
+                                   skip)
+
+  prepare_pn_with_markings(sync_net, convert)
+}

R/petrinet.R

@@ -0,0 +1,18 @@
+#' PM4PY for R
+#'
+#' This package provides acces to the Python Process Mining library PM4PY in R
+#' and provides conversion between bupaR and PM4PY data structures.
+#'
+#' The object `pm4py` provides the interface to the main PM4PY module .
+#' Use `$` to access sub modules of PM4PY as described in the `reticulate`
+#' documentation:
+#' \code{vignette("calling_python", package = "reticulate")}
+#'
+#' @examples
+#' \dontrun{
+#' # Print the PM4PY version loaded
+#' pm4py$`__version__`
+#' }
+#'
+#' @export
+pm4py <- NULL

R/pm4py.R

@@ -0,0 +1,79 @@
+
+prepare_pn_with_markings <- function(model, convert = FALSE) {
+  if (convert) {
+    if (inherits(model, "python.builtin.object")) {
+      model <- py_to_r(model) # Python tuple was not auto-converted
+    }
+    model <- lapply(model, py_to_r)
+    names(model) <- c("petrinet","initial_marking", "final_marking")
+    model$petrinet$marking <- model$initial_marking
+  }
+  model
+}
+
+ensure_str <- function(x) {
+  # Taking the Python string representation, but bupaR does not like ' in names
+  # TODO fix in bupaR
+  if (is.null(x)) {
+    NA_character_
+  } else {
+    stringr::str_remove_all(py_str(as_py_value(x)), stringr::fixed("'"))
+  }
+}
+
+as_pm4py_marking <- function(x, petrinet) {
+
+  if (inherits(x, "pm4py.objects.petri.petrinet.Marking")) {
+    return(x)
+  }
+
+  pm4py_petrinet <- import("pm4py.objects.petri.petrinet", convert = FALSE)
+  marking <- pm4py_petrinet$Marking()
+
+  found <- rep(FALSE, length(x))
+  py <- import_builtins()
+  iter <- py$iter(petrinet$places)
+
+  while (TRUE) {
+    item <- iter_next(iter)
+    if (is.null(item))
+      break
+
+    loc <- which(x == item$name)
+    if (any(loc)) {
+      found[loc] <- TRUE
+      marking[item] = length(loc)
+    }
+  }
+
+  if (all(found)) {
+    return(marking)
+  } else {
+    stop(paste0("Places ",
+                paste0(x[!found], collapse = ","),
+                " not found in ",
+                py_str(petrinet$places)))
+  }
+}
+
+as_r_value <- function(x) {
+
+  if (inherits(x, "python.builtin.object"))
+    py_to_r(x)
+  else
+    x
+}
+
+as_py_value <- function(x) {
+
+  if (inherits(x, "python.builtin.object"))
+    x
+  else
+    r_to_py(x)
+}
+
+skip_if_no_pm4py <- function() {
+  have_pm4py <- py_module_available("pm4py")
+  if (!have_pm4py)
+    testthat::skip("pm4py not available for testing")
+}

R/utils.R

@@ -0,0 +1,45 @@
+# pm4py
+
+The goal of pm4py is to provide a bridge to the Python library PM4PY developed at: http://pm4py.org/
+
+## Installation
+
+You can install the development version of pm4py with:
+
+``` r
+remotes::install_github("fmannhardt/pm4py")
+```
+
+## Example
+
+``` r
+library(pm4py)
+library(bupaR)
+
+#
+# Discovery with Inductive Miner
+#
+pn <- discovery_inductive(patients)
+
+# result is auto converted to petrinetR object plus markings
+str(pn)
+class(pn$petrinet)
+
+# Render with bupaR
+render_PN(pn$petrinet)
+
+#
+# Render with  PM4PY and DiagrammeR
+#
+library(DiagrammeR)
+viz <- import("pm4py.visualization.petrinet")
+
+# Convert back to Python
+py_pn <- r_to_py(pn$petrinet)
+class(py_pn)
+
+# Render to DOT with PMP4Y
+dot <- viz$factory$apply(py_pn)$source
+grViz(diagram = dot)
+```
+

README.md

@@ -0,0 +1,21 @@
+Version: 1.0
+
+RestoreWorkspace: No
+SaveWorkspace: No
+AlwaysSaveHistory: Default
+
+EnableCodeIndexing: Yes
+UseSpacesForTab: Yes
+NumSpacesForTab: 2
+Encoding: ISO8859-1
+
+RnwWeave: Sweave
+LaTeX: pdfLaTeX
+
+AutoAppendNewline: Yes
+StripTrailingWhitespace: Yes
+
+BuildType: Package
+PackageUseDevtools: Yes
+PackageInstallArgs: --no-multiarch --with-keep.source
+PackageRoxygenize: rd,collate,namespace,vignette

_pkgdown.yml

@@ -0,0 +1,4 @@
+library(testthat)
+library(pm4py)
+
+test_check("pm4py")

man/conformance_alignment.Rd

@@ -0,0 +1,20 @@
+context("Discovery")
+
+library(bupaR)
+
+test_that("Inductive miner", {
+  skip_if_no_pm4py()
+
+  data("patients")
+
+  net <- expect_silent(discovery_inductive(patients, convert = FALSE))
+  expect_true("pm4py.objects.petri.petrinet.PetriNet" %in% class(net[0]))
+  expect_true("pm4py.objects.petri.petrinet.Marking" %in% class(net[1]))
+  expect_true("pm4py.objects.petri.petrinet.Marking" %in% class(net[2]))
+
+  net <- expect_silent(discovery_inductive(patients, convert = TRUE))
+  expect_s3_class(net$petrinet, "petrinet")
+  expect_length(net$initial_marking, 1)
+  expect_length(net$final_marking, 1)
+
+})