tests/testthat/test-plot-trajectory.R

In r-simmer/simmer.plot: Plotting Methods for 'simmer'

test_graph <- function(x, name, from, to) {
  expect_true(inherits(plot(x), "htmlwidget"))
  graph <- trajectory_graph(x, scales::brewer_pal("qual"))
  expect_true(inherits(graph, "dgr_graph"))

  nodes_df <- dplyr::arrange(graph$nodes_df, .data$id)
  edges_df <- dplyr::arrange(graph$edges_df, .data$from, .data$to)
  expect_equal(nodes_df$label, name)
  expect_equal(edges_df$from, from)
  expect_equal(edges_df$to, to)
}

test_that("a null trajectory fails", {
  expect_error(plot(trajectory()))
})

test_that("a single-node trajectory is correctly converted to graph", {
  x <- trajectory() %>%
    timeout(1)

  test_graph(x, c("Timeout"), integer(0), integer(0))
})

test_that("a simple trajectory is correctly converted to graph", {
  x <- trajectory() %>%
    seize("res", 1) %>%
    release("res", 1)

  test_graph(x, c("Seize", "Release"), 1, 2)
})

test_that("a rollback with variable amount is correctly converted to graph", {
  test_graph(trajectory() %>% rollback(0), c("Rollback"), 1, 1)
  test_graph(trajectory() %>% rollback(1), c("Rollback"), 1, 1)
  test_graph(trajectory() %>% rollback(Inf), c("Rollback"), 1, 1)
  test_graph(trajectory() %>% timeout(1) %>% rollback(0), c("Timeout", "Rollback"), c(1, 2), c(2, 2))
  test_graph(trajectory() %>% timeout(1) %>% rollback(1), c("Timeout", "Rollback"), c(1, 2), c(2, 1))
  test_graph(trajectory() %>% timeout(1) %>% rollback(2), c("Timeout", "Rollback"), c(1, 2), c(2, 1))
  test_graph(trajectory() %>% timeout(1) %>% rollback(Inf), c("Timeout", "Rollback"), c(1, 2), c(2, 1))
})

test_that("a rollback with tag is correctly converted to graph", {
  skip_if(packageVersion("simmer") <= "4.4.5")

  x <- trajectory() %>%
    timeout(1, tag="foo") %>%
    timeout(2, tag="foo") %>%
    timeout(3) %>%
    rollback("foo", tag="bar")

  test_graph(x,
             c("Timeout [foo]", "Timeout [foo]", "Timeout", "Rollback [bar]"),
             c(1, 2, 3, 4),
             c(2, 3, 4, 2))
})

test_that("a complex trajectory is correctly converted to graph", {
  x <- trajectory() %>%
    seize("res0", 1) %>%
    branch(function() 1, c(TRUE, FALSE),
           trajectory() %>%
             clone(2,
                   trajectory() %>%
                     seize("res1", 1) %>%
                     timeout(1) %>%
                     release("res1", 1),
                   trajectory() %>%
                     trap("signal",
                          handler=trajectory() %>%
                            timeout(1)) %>%
                     timeout(1)),
           trajectory() %>%
             set_attribute("dummy", 1) %>%
             seize("res2", function() 1) %>%
             timeout(function() rnorm(1, 20)) %>%
             release("res2", function() 1) %>%
             release("res0", 1) %>%
             rollback(11)) %>%
    synchronize() %>%
    rollback(2) %>%
    release("res0", 1)

  activities <- c("Seize", "Branch", "Clone", "Seize", "Timeout", "Release", "Trap",
                  "Timeout", "Timeout", "SetAttribute", "Seize", "Timeout", "Release",
                  "Release", "Rollback", "Synchronize", "Rollback", "Release")
  from <- c(1, 2, 2, 2, 3, 3, 4, 5, 6, 7, 7, 9, 10, 11, 12, 13, 14, 15, 16, 17, 17)
  to <- c(2, 3, 10, 16, 4, 7, 5, 6, 16, 8, 9, 16, 11, 12, 13, 14, 15, 1, 17, 2, 18)

  if (packageVersion("simmer") >= "4.2.2") {
    # connect the Timeout back to the Handler
    pos <- 1:11
    from <- c(from[pos], 8, from[-pos])
    to <- c(to[pos], 7, to[-pos])
  }

  test_graph(x, activities, from, to)
})

test_that("edges are removed for ignored subtrajectories in Clone", {
  x <- trajectory() %>%
    clone(3,
          trajectory() %>% timeout(1),
          trajectory() %>% set_attribute("asdf", 1)) %>%
    clone(2,
          trajectory() %>% timeout(1),
          trajectory() %>% set_attribute("asdf", 1)) %>%
    clone(1,
          trajectory() %>% timeout(1),
          trajectory() %>% set_attribute("asdf", 1)) %>%
    clone(0,
          trajectory() %>% timeout(1),
          trajectory() %>% set_attribute("asdf", 1)) %>%
    synchronize()

  test_graph(x,
             c("Clone", "Timeout", "SetAttribute", "Clone", "Timeout", "SetAttribute",
               "Clone", "Timeout", "SetAttribute", "Clone", "Timeout", "SetAttribute", "Synchronize"),
             c(1, 1, 1, 2, 3, 4, 4, 5, 6, 7, 8, 9, 11, 12),
             c(2, 3, 4, 4, 4, 5, 6, 7, 7, 8, 10, 10, 13, 13))
})

test_that("edges are not postprocessed when n is specified as a function", {
  x <- trajectory() %>%
    clone(function() 3,
          trajectory() %>% timeout(1),
          trajectory() %>% set_attribute("asdf", 1)) %>%
    clone(function() 2,
          trajectory() %>% timeout(1),
          trajectory() %>% set_attribute("asdf", 1)) %>%
    clone(function() 1,
          trajectory() %>% timeout(1),
          trajectory() %>% set_attribute("asdf", 1)) %>%
    clone(function() 0,
          trajectory() %>% timeout(1),
          trajectory() %>% set_attribute("asdf", 1)) %>%
    synchronize()

  test_graph(x,
             c("Clone", "Timeout", "SetAttribute", "Clone", "Timeout", "SetAttribute",
               "Clone", "Timeout", "SetAttribute", "Clone", "Timeout", "SetAttribute", "Synchronize"),
             c(1, 1, 1, 2, 3, 4, 4, 4, 5, 6, 7, 7, 7, 8, 9, 10, 10, 10, 11, 12),
             c(2, 3, 4, 4, 4, 5, 6, 7, 7, 7, 8, 9, 10, 10, 10, 11, 12, 13, 13, 13))
})